c -> Prop, q :: a -> b -> Prop, r :: a -> c -> Prop>. + {-@ + (.) :: forall
c -> Prop, q :: a -> b -> Prop, r :: a -> c -> Prop>.
{x::a, w::b <: c )
-> (z:a -> b Bool>. (a -> {v:Bool| v}) -> a -> a @-}
-liquidAssumeB :: (a -> Bool) -> a -> a
-liquidAssumeB p x | p x = x
- | otherwise = error "liquidAssumeB fails"
-
-
-{-@ ignore unsafeError @-}
-{-# NOINLINE unsafeError #-}
-unsafeError :: String -> a
-unsafeError = error
-
-
-{-@ liquidError :: {v:String | 0 = 1} -> a @-}
-{-# NOINLINE liquidError #-}
-liquidError :: String -> a
-liquidError = error
-
-{-@ assume crash :: forall a . x:{v:Bool | v} -> a @-}
-{-# NOINLINE crash #-}
-crash :: Bool -> a
-crash = undefined
-
-{-# NOINLINE force #-}
-force :: Bool
-force = True
-
-{-# NOINLINE choose #-}
-choose :: Int -> Int
-choose = undefined
-
--------------------------------------------------------------------
------------ Modular Arithmetic Wrappers ---------------------------
--------------------------------------------------------------------
-
--- tedium because fixpoint doesn't want to deal with (x mod y) only (x mod c)
-{-@ assume isEven :: x:Int -> {v:Bool | ((v) <=> ((x mod 2) = 0))} @-}
-{-# NOINLINE isEven #-}
-isEven :: Int -> Bool
-isEven x = x `mod` 2 == 0
-
-{-@ assume isOdd :: x:Int -> {v:Bool | ((v) <=> ((x mod 2) = 1))} @-}
-{-# NOINLINE isOdd #-}
-isOdd :: Int -> Bool
-isOdd x = x `mod` 2 == 1
-
------------------------------------------------------------------------------------------------
-
-{-@ safeZipWith :: (a -> b -> c) -> xs : [a] -> ys:{v:[b] | len v = len xs}
- -> {v : [c] | len v = len xs } @-}
-safeZipWith :: (a->b->c) -> [a]->[b]->[c]
-safeZipWith f (a:as) (b:bs) = f a b : safeZipWith f as bs
-safeZipWith _ [] [] = []
-safeZipWith _ _ _ = error "safeZipWith: cannot happen!"
-
-{-@ (==>) :: p:Bool -> q:Bool -> {v:Bool | v <=> (p => q)} @-}
-infixr 8 ==>
-(==>) :: Bool -> Bool -> Bool
-False ==> False = True
-False ==> True = True
-True ==> True = True
-True ==> False = False
diff --git a/include/Language/Haskell/Liquid/Prelude.pred b/include/Language/Haskell/Liquid/Prelude.pred
deleted file mode 100644
--- a/include/Language/Haskell/Liquid/Prelude.pred
+++ /dev/null
@@ -1,22 +0,0 @@
-assume (>) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
-assume (<) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
-assume (>=) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
-assume (<=) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
-assume (==) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool
-assume (+) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True
-assume (*) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True
-assume (-) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True
-assume ($) :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2) -> a^q1 -> b^q2
-assume (.) :: forall b c a. forAll q1:a q2:b q3:c. (b^q2 -> c^q3) -> (a^q1 -> b^q2) -> a^q1 -> c^q3
-assume filter :: forall a. forAll p1:a. (a^p1 -> Bool) -> [a^p1]-> [a^p1]
-assume snd :: forall a b. forAll p1:a p2:b. (a^p1, b^p2)-> b^p2
-assume map :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2) -> [a^q1]-> [b^q2]
-assume (++) :: forall a. forAll q:a. [a^q]-> [a^q]-> [a^q]
-assume concat :: forall a. forAll q:a. [[a^q]]-> [a^q]
-assume foldl :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2 -> a^q1) -> a^q1 -> [b^q2]-> a^q1
-assume foldr :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2 -> b^q2) -> b^q2 -> [a^q1]-> b^q2
-assume (,) :: forall a b. forAll q1:a q2:b. a^q1 -> b^q2 ->(a^q1, b^q2)
-assume Prelude.error :: forall a. forAll q2:a. [Char]-> a^q2
-assume Prelude.head :: forall a. forAll q:a. [a^q]-> a^q
-assume Prelude.tail :: forall a. forAll q:a. [a^q]-> [a^q]
-assume Prelude.enumFromTo :: forall a. forAll q:a. (Enum a^ True) => a^q -> a^q -> [a^q]
diff --git a/include/Language/Haskell/Liquid/ProofCombinators.hs b/include/Language/Haskell/Liquid/ProofCombinators.hs
deleted file mode 100644
--- a/include/Language/Haskell/Liquid/ProofCombinators.hs
+++ /dev/null
@@ -1,183 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE IncoherentInstances #-}
-
-module Language.Haskell.Liquid.ProofCombinators (
-
- -- ATTENTION! `Admit` and `(==!)` are UNSAFE: they should not belong the final proof term
-
- -- * Proof is just a () alias
- Proof
- , toProof
-
- -- * Proof constructors
- , trivial, unreachable, (***), QED(..)
-
- -- * Proof certificate constructors
- , (?)
-
- -- * These two operators check all intermediate equalities
- , (===) -- proof of equality is implicit eg. x === y
- , (=<=) -- proof of equality is implicit eg. x <= y
- , (=>=) -- proof of equality is implicit eg. x =>= y
-
- -- * This operator does not check intermediate equalities
- , (==.)
-
- -- Uncheck operator used only for proof debugging
- , (==!) -- x ==! y always succeeds
-
- -- * Combining Proofs
- , (&&&)
- , withProof
- , impossible
-
-
-) where
-
--------------------------------------------------------------------------------
--- | Proof is just a () alias -------------------------------------------------
--------------------------------------------------------------------------------
-
-type Proof = ()
-
-toProof :: a -> Proof
-toProof _ = ()
-
--------------------------------------------------------------------------------
--- | Proof Construction -------------------------------------------------------
--------------------------------------------------------------------------------
-
--- | trivial is proof by SMT
-
-trivial :: Proof
-trivial = ()
-
--- {-@ unreachable :: {v : Proof | False } @-}
-unreachable :: Proof
-unreachable = ()
-
--- All proof terms are deleted at runtime.
-{- RULE "proofs are irrelevant" forall (p :: Proof). p = () #-}
-
--- | proof casting
--- | `x *** QED`: x is a proof certificate* strong enough for SMT to prove your theorem
--- | `x *** Admit`: x is an unfinished proof
-
-infixl 3 ***
-{-@ assume (***) :: a -> p:QED -> { if (isAdmit p) then false else true } @-}
-(***) :: a -> QED -> Proof
-_ *** _ = ()
-
-data QED = Admit | QED
-
-{-@ measure isAdmit :: QED -> Bool @-}
-{-@ Admit :: {v:QED | isAdmit v } @-}
-
-
--------------------------------------------------------------------------------
--- | * Checked Proof Certificates ---------------------------------------------
--------------------------------------------------------------------------------
-
--- Any (refined) carries proof certificates.
--- For example 42 :: {v:Int | v == 42} is a certificate that
--- the value 42 is equal to 42.
--- But, this certificate will not really be used to proof any fancy theorems.
-
--- Below we provide a number of equational operations
--- that constuct proof certificates.
-
--- | Implicit equality
-
--- x === y returns the proof certificate that
--- result value is equal to both x and y
--- when y == x (as assumed by the operator's precondition)
-
-infixl 3 ===
-{-@ (===) :: x:a -> y:{a | y == x} -> {v:a | v == x && v == y} @-}
-(===) :: a -> a -> a
-_ === y = y
-
-infixl 3 =<=
-{-@ (=<=) :: x:a -> y:{a | x <= y} -> {v:a | v == y} @-}
-(=<=) :: a -> a -> a
-_ =<= y = y
-
-infixl 3 =>=
-{-@ (=>=) :: x:a -> y:{a | x >= y} -> {v:a | v == y} @-}
-(=>=) :: a -> a -> a
-_ =>= y = y
-
--------------------------------------------------------------------------------
--- | `?` is basically Haskell's $ and is used for the right precedence
--- | `?` lets you "add" some fact into a proof term
--------------------------------------------------------------------------------
-
-infixl 3 ?
-
-{-@ (?) :: forall a b c -> Bool, q :: a -> b -> Bool, r :: a -> c -> Bool>.
- {xcmp::a, wcmp::b <: c )
- -> (zcmp:a -> b c -> Bool, q :: a -> b -> Bool, r :: a -> c -> Bool>.
+ {xcmp::a, wcmp::b <: c )
+ -> (zcmp:a -> b ===> {v:Int | p v}
-
- which is fine, but also converts
-
- Field Int' (if List has an abs-ref).
-plainRTyConPVars :: TyConMap -> RTyCon -> (RTyCon, [RPVar])
-plainRTyConPVars tyi rc = (rc', rTyConPVs rc')
- where
- rc' = M.lookupDefault rc (rtc_tc rc) (tcmTyRTy tyi)
-
-
-
--- RJ: The code of `isNumeric` is incomprehensible.
--- Please fix it to use intSort instead of intFTyCon
-isNumeric :: TCEmb TyCon -> RTyCon -> Bool
-isNumeric tce c = F.isNumeric mySort
- where
- -- mySort = M.lookupDefault def rc tce
- mySort = maybe def fst (F.tceLookup rc tce)
- def = FTC . symbolFTycon . dummyLoc . tyConName $ rc
- rc = rtc_tc c
-
-addNumSizeFun :: RTyCon -> RTyCon
-addNumSizeFun c
- = c {rtc_info = (rtc_info c) {sizeFunction = Just IdSizeFun } }
-
-
-generalize :: (Eq tv, Monoid r) => RType c tv r -> RType c tv r
-generalize t = mkUnivs (zip (freeTyVars t) (repeat mempty)) [] t
-
-allTyVars :: (Ord tv) => RType c tv r -> [tv]
-allTyVars t = sortNub . fmap ty_var_value $ vs ++ vs'
- where
- vs = map fst . fst3 . bkUniv $ t
- vs' = freeTyVars $ t
-
-freeTyVars :: Eq tv => RType c tv r -> [RTVar tv (RType c tv ())]
-freeTyVars (RAllP _ t) = freeTyVars t
-freeTyVars (RAllT α t _) = freeTyVars t L.\\ [α]
-freeTyVars (RImpF _ t t' _)= freeTyVars t `L.union` freeTyVars t'
-freeTyVars (RFun _ t t' _) = freeTyVars t `L.union` freeTyVars t'
-freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts
-freeTyVars (RVar α _) = [makeRTVar α]
-freeTyVars (RAllE _ tx t) = freeTyVars tx `L.union` freeTyVars t
-freeTyVars (REx _ tx t) = freeTyVars tx `L.union` freeTyVars t
-freeTyVars (RExprArg _) = []
-freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t'
-freeTyVars (RHole _) = []
-freeTyVars (RRTy e _ _ t) = L.nub $ concatMap freeTyVars (t:(snd <$> e))
-
-
-tyClasses :: (OkRT RTyCon tv r) => RType RTyCon tv r -> [(Class, [RType RTyCon tv r])]
-tyClasses (RAllP _ t) = tyClasses t
-tyClasses (RAllT _ t _) = tyClasses t
-tyClasses (RAllE _ _ t) = tyClasses t
-tyClasses (REx _ _ t) = tyClasses t
-tyClasses (RImpF _ t t' _) = tyClasses t ++ tyClasses t'
-tyClasses (RFun _ t t' _) = tyClasses t ++ tyClasses t'
-tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t'
-tyClasses (RApp c ts _ _)
- | Just cl <- tyConClass_maybe $ rtc_tc c
- = [(cl, ts)]
- | otherwise
- = []
-tyClasses (RVar _ _) = []
-tyClasses (RRTy _ _ _ t) = tyClasses t
-tyClasses (RHole _) = []
-tyClasses t = panic Nothing ("RefType.tyClasses cannot handle" ++ show t)
-
-
---------------------------------------------------------------------------------
--- TODO: Rewrite subsTyvars with Traversable
---------------------------------------------------------------------------------
-
-subsTyVars_meet
- :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => t (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r
-subsTyVars_meet = subsTyVars True
-
-subsTyVars_nomeet
- :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => t (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r
-subsTyVars_nomeet = subsTyVars False
-
-subsTyVar_nomeet
- :: (Eq tv, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r
-subsTyVar_nomeet = subsTyVar False
-
-subsTyVar_meet
- :: (Eq tv, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => (tv, RType c tv (), RType c tv r) -> RType c tv r -> RType c tv r
-subsTyVar_meet = subsTyVar True
-
-subsTyVar_meet'
- :: (Eq tv, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => (tv, RType c tv r) -> RType c tv r -> RType c tv r
-subsTyVar_meet' (α, t) = subsTyVar_meet (α, toRSort t, t)
-
-subsTyVars
- :: (Eq tv, Foldable t, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => Bool
- -> t (tv, RType c tv (), RType c tv r)
- -> RType c tv r
- -> RType c tv r
-subsTyVars meet ats t = foldl' (flip (subsTyVar meet)) t ats
-
-subsTyVar
- :: (Eq tv, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => Bool
- -> (tv, RType c tv (), RType c tv r)
- -> RType c tv r
- -> RType c tv r
-subsTyVar meet = subsFree meet S.empty
-
-subsFree
- :: (Eq tv, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => Bool
- -> S.HashSet tv
- -> (tv, RType c tv (), RType c tv r)
- -> RType c tv r
- -> RType c tv r
-subsFree m s z@(α, τ,_) (RAllP π t)
- = RAllP (subt (α, τ) π) (subsFree m s z t)
-subsFree m s z@(a, τ, _) (RAllT α t r)
- -- subt inside the type variable instantiates the kind of the variable
- = RAllT (subt (a, τ) α) (subsFree m (ty_var_value α `S.insert` s) z t) (subt (a, τ) r)
-subsFree m s z@(α, τ, _) (RImpF x t t' r)
- = RImpF x (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r)
-subsFree m s z@(α, τ, _) (RFun x t t' r)
- = RFun x (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r)
-subsFree m s z@(α, τ, _) (RApp c ts rs r)
- = RApp c' (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) (subt (α, τ) r)
- where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters?
- c' = if α `S.member` s then c else subt z' c
-subsFree meet s (α', τ, t') (RVar α r)
- | α == α' && not (α `S.member` s)
- = if meet then t' `strengthen` (subt (α, τ) r) else t'
- | otherwise
- = RVar (subt (α', τ) α) r
-subsFree m s z (RAllE x t t')
- = RAllE x (subsFree m s z t) (subsFree m s z t')
-subsFree m s z (REx x t t')
- = REx x (subsFree m s z t) (subsFree m s z t')
-subsFree m s z@(α, τ, _) (RAppTy t t' r)
- = subsFreeRAppTy m s (subsFree m s z t) (subsFree m s z t') (subt (α, τ) r)
-subsFree _ _ _ t@(RExprArg _)
- = t
-subsFree m s z@(α, τ, _) (RRTy e r o t)
- = RRTy (mapSnd (subsFree m s z) <$> e) (subt (α, τ) r) o (subsFree m s z t)
-subsFree _ _ (α, τ, _) (RHole r)
- = RHole (subt (α, τ) r)
-
-subsFrees
- :: (Eq tv, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => Bool
- -> S.HashSet tv
- -> [(tv, RType c tv (), RType c tv r)]
- -> RType c tv r
- -> RType c tv r
-subsFrees m s zs t = foldl' (flip (subsFree m s)) t zs
-
--- GHC INVARIANT: RApp is Type Application to something other than TYCon
-subsFreeRAppTy
- :: (Eq tv, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()),
- FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => Bool
- -> S.HashSet tv
- -> RType c tv r
- -> RType c tv r
- -> r
- -> RType c tv r
-subsFreeRAppTy m s (RApp c ts rs r) t' r'
- = mkRApp m s c (ts ++ [t']) rs r r'
-subsFreeRAppTy _ _ t t' r'
- = RAppTy t t' r'
-
-
--- | @mkRApp@ is the refined variant of GHC's @mkTyConApp@ which ensures that
--- that applications of the "function" type constructor are normalized to
--- the special case @FunTy _@ representation. The extra `_rep1`, and `_rep2`
--- parameters come from the "levity polymorphism" changes in GHC 8.6 (?)
--- See [NOTE:Levity-Polymorphism]
-
-mkRApp :: (Eq tv, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => Bool
- -> S.HashSet tv
- -> c
- -> [RType c tv r]
- -> [RTProp c tv r]
- -> r
- -> r
- -> RType c tv r
-mkRApp m s c ts rs r r'
- | isFun c, [_rep1, _rep2, t1, t2] <- ts
- = RFun dummySymbol t1 t2 (refAppTyToFun r')
- | otherwise
- = subsFrees m s zs (RApp c ts rs (r `meet` r'))
- where
- zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts]
-
-{-| [NOTE:Levity-Polymorphism]
-
- Thanks to Joachim Brietner and Simon Peyton-Jones!
- With GHC's "levity polymorphism feature", see more here
-
- https://stackoverflow.com/questions/35318562/what-is-levity-polymorphism
-
- The function type constructor actually has type
-
- (->) :: forall (r1::RuntimeRep) (r2::RuntimeRep). TYPE r1 -> TYPE r2 -> TYPE LiftedRep
-
- so we have to be careful to follow GHC's @mkTyConApp@
-
- https://hackage.haskell.org/package/ghc-8.6.4/docs/src/Type.html#mkTyConApp
-
- which normalizes applications of the `FunTyCon` constructor to use the special
- case `FunTy _` representation thus, so that we are not stuck with incompatible
- representations e.g.
-
- thing -> thing ... (using RFun)
-
- and
-
- (-> 'GHC.Types.LiftedRep 'GHC.Types.LiftedRep thing thing) ... (using RApp)
-
-
- More details from Joachim Brietner:
-
- Now you might think that the function arrow has the following kind: `(->) :: * -> * -> *`.
- But that is not the full truth: You can have functions that accept or return things with
- different representations than just the usual lifted one.
-
- So the function arrow actually has kind `(->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> *`.
- And in `(-> 'GHC.Types.LiftedRep 'GHC.Types.LiftedRep thing thing)` you see this spelled
- out explicitly. But it really is just `(thing -> thing)`, just printed with more low-level detail.
-
- Also see
-
- • https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#levity-polymorphism
- • and other links from https://stackoverflow.com/a/35320729/946226 (edited)
- -}
-
-refAppTyToFun :: Reftable r => r -> r
-refAppTyToFun r
- | isTauto r = r
- | otherwise = panic Nothing "RefType.refAppTyToFun"
-
-subsFreeRef
- :: (Eq tv, Hashable tv, Reftable r, TyConable c,
- SubsTy tv (RType c tv ()) c, SubsTy tv (RType c tv ()) r,
- SubsTy tv (RType c tv ()) (RType c tv ()), FreeVar c tv,
- SubsTy tv (RType c tv ()) tv,
- SubsTy tv (RType c tv ()) (RTVar tv (RType c tv ())))
- => Bool
- -> S.HashSet tv
- -> (tv, RType c tv (), RType c tv r)
- -> RTProp c tv r
- -> RTProp c tv r
-subsFreeRef _ _ (α', τ', _) (RProp ss (RHole r))
- = RProp (mapSnd (subt (α', τ')) <$> ss) (RHole r)
-subsFreeRef m s (α', τ', t') (RProp ss t)
- = RProp (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t
-
-
---------------------------------------------------------------------------------
--- | Type Substitutions --------------------------------------------------------
---------------------------------------------------------------------------------
-
-subts :: (SubsTy tv ty c) => [(tv, ty)] -> c -> c
-subts = flip (foldr subt)
-
-instance SubsTy RTyVar (RType RTyCon RTyVar ()) RTyVar where
- subt (RTV x, t) (RTV z) | isTyVar z, tyVarKind z == TyVarTy x
- = RTV (setVarType z $ toType t)
- subt _ v
- = v
-
-instance SubsTy RTyVar (RType RTyCon RTyVar ()) (RTVar RTyVar (RType RTyCon RTyVar ())) where
- -- NV TODO: update kind
- subt su rty = rty { ty_var_value = subt su $ ty_var_value rty }
-
-
-instance SubsTy BTyVar (RType c BTyVar ()) BTyVar where
- subt _ = id
-
-instance SubsTy BTyVar (RType c BTyVar ()) (RTVar BTyVar (RType c BTyVar ())) where
- subt _ = id
-
-instance SubsTy tv ty () where
- subt _ = id
-
-instance SubsTy tv ty Symbol where
- subt _ = id
-
-
-
-instance (SubsTy tv ty Expr) => SubsTy tv ty Reft where
- subt su (Reft (x, e)) = Reft (x, subt su e)
-
-instance SubsTy Symbol Symbol (BRType r) where
- subt (x,y) (RVar v r)
- | BTV x == v = RVar (BTV y) r
- | otherwise = RVar v r
- subt (x, y) (RAllT (RTVar v i) t r)
- | BTV x == v = RAllT (RTVar v i) t r
- | otherwise = RAllT (RTVar v i) (subt (x,y) t) r
- subt su (RFun x t1 t2 r) = RFun x (subt su t1) (subt su t2) r
- subt su (RImpF x t1 t2 r) = RImpF x (subt su t1) (subt su t2) r
- subt su (RAllP p t) = RAllP p (subt su t)
- subt su (RApp c ts ps r) = RApp c (subt su <$> ts) (subt su <$> ps) r
- subt su (RAllE x t1 t2) = RAllE x (subt su t1) (subt su t2)
- subt su (REx x t1 t2) = REx x (subt su t1) (subt su t2)
- subt _ (RExprArg e) = RExprArg e
- 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)
-
-
-
-instance (SubsTy tv ty Sort) => SubsTy tv ty Expr where
- subt su (ELam (x, s) e) = ELam (x, subt su s) $ subt su e
- subt su (EApp e1 e2) = EApp (subt su e1) (subt su e2)
- subt su (ENeg e) = ENeg (subt su e)
- subt su (PNot e) = PNot (subt su e)
- subt su (EBin b e1 e2) = EBin b (subt su e1) (subt su e2)
- subt su (EIte e e1 e2) = EIte (subt su e) (subt su e1) (subt su e2)
- subt su (ECst e s) = ECst (subt su e) (subt su s)
- subt su (ETApp e s) = ETApp (subt su e) (subt su s)
- subt su (ETAbs e x) = ETAbs (subt su e) x
- subt su (PAnd es) = PAnd (subt su <$> es)
- subt su (POr es) = POr (subt su <$> es)
- subt su (PImp e1 e2) = PImp (subt su e1) (subt su e2)
- subt su (PIff e1 e2) = PIff (subt su e1) (subt su e2)
- subt su (PAtom b e1 e2) = PAtom b (subt su e1) (subt su e2)
- subt su (PAll xes e) = PAll (subt su <$> xes) (subt su e)
- subt su (PExist xes e) = PExist (subt su <$> xes) (subt su e)
- subt _ e = e
-
-instance (SubsTy tv ty a, SubsTy tv ty b) => SubsTy tv ty (a, b) where
- subt su (x, y) = (subt su x, subt su y)
-
-instance SubsTy BTyVar (RType BTyCon BTyVar ()) Sort where
- subt (v, RVar α _) (FObj s)
- | symbol v == s = FObj $ symbol α
- | otherwise = FObj s
- subt _ s = s
-
-
-instance SubsTy Symbol RSort Sort where
- subt (v, RVar α _) (FObj s)
- | symbol v == s = FObj $ symbol {- rTyVarSymbol -} α
- | otherwise = FObj s
- subt _ s = s
-
-
-instance SubsTy RTyVar RSort Sort where
- subt (v, sv) (FObj s)
- | symbol v == s = typeSort mempty (toType sv)
- | otherwise = FObj s
- subt _ s = s
-
-instance (SubsTy tv ty ty) => SubsTy tv ty (PVKind ty) where
- subt su (PVProp t) = PVProp (subt su t)
- subt _ PVHProp = PVHProp
-
-instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where
- subt su (PV n t v xts) = PV n (subt su t) v [(subt su t, x, y) | (t,x,y) <- xts]
-
-instance SubsTy RTyVar RSort RTyCon where
- subt z c = RTyCon tc ps' i
- where
- tc = rtc_tc c
- ps' = subt z <$> rTyConPVs c
- i = rtc_info c
-
--- NOTE: This DOES NOT substitute at the binders
-instance SubsTy RTyVar RSort PrType where
- subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)
-
-instance SubsTy RTyVar RSort SpecType where
- subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)
-
-instance SubsTy TyVar Type SpecType where
- subt (α, τ) = subsTyVar_meet (RTV α, ofType τ, ofType τ)
-
-instance SubsTy RTyVar RTyVar SpecType where
- subt (α, a) = subt (α, RVar a () :: RSort)
-
-
-instance SubsTy RTyVar RSort RSort where
- subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)
-
-instance SubsTy tv RSort Predicate where
- subt _ = id -- NV TODO
-
-instance (SubsTy tv ty r) => SubsTy tv ty (UReft r) where
- subt su r = r {ur_reft = subt su $ ur_reft r}
-
--- Here the "String" is a Bare-TyCon. TODO: wrap in newtype
-instance SubsTy BTyVar BSort BTyCon where
- subt _ t = t
-
-instance SubsTy BTyVar BSort BSort where
- subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ)
-
-instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType c tv ())) => SubsTy tv ty (RTProp c tv (UReft r)) where
- subt m (RProp ss (RHole p)) = RProp ((mapSnd (subt m)) <$> ss) $ RHole $ subt m p
- subt m (RProp ss t) = RProp ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t
-
-subvUReft :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft
-subvUReft f (MkUReft r p) = MkUReft r (subvPredicate f p)
-
-subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate
-subvPredicate f (Pr pvs) = Pr (f <$> pvs)
-
---------------------------------------------------------------------------------
-ofType :: Monoid r => Type -> RRType r
---------------------------------------------------------------------------------
-ofType = ofType_ $ TyConv
- { tcFVar = rVar
- , tcFTVar = rTVar
- , tcFApp = \c ts -> rApp c ts [] mempty
- , tcFLit = ofLitType rApp
- }
-
---------------------------------------------------------------------------------
-bareOfType :: Monoid r => Type -> BRType r
---------------------------------------------------------------------------------
-bareOfType = ofType_ $ TyConv
- { tcFVar = (`RVar` mempty) . BTV . symbol
- , tcFTVar = bTVar
- , tcFApp = \c ts -> bApp c ts [] mempty
- , tcFLit = ofLitType bApp
- }
-
---------------------------------------------------------------------------------
-ofType_ :: Monoid r => TyConv c tv r -> Type -> RType c tv r
---------------------------------------------------------------------------------
-ofType_ tx = go . expandTypeSynonyms
- where
- go (TyVarTy α)
- = tcFVar tx α
- go (FunTy _ τ τ')
- = rFun dummySymbol (go τ) (go τ')
- go (ForAllTy (Bndr α _) τ)
- = RAllT (tcFTVar tx α) (go τ) mempty
- go (TyConApp c τs)
- | Just (αs, τ) <- TC.synTyConDefn_maybe c
- = go (substTyWith αs τs τ)
- | otherwise
- = tcFApp tx c (go <$> τs) -- [] mempty
- go (AppTy t1 t2)
- = RAppTy (go t1) (ofType_ tx t2) mempty
- go (LitTy x)
- = tcFLit tx x
- go (CastTy t _)
- = go t
- go (CoercionTy _)
- = errorstar "Coercion is currently not supported"
-
-ofLitType :: (Monoid r) => (TyCon -> [RType c tv r] -> [p] -> r -> RType c tv r) -> TyLit -> RType c tv r
-ofLitType rF (NumTyLit _) = rF intTyCon [] [] mempty
-ofLitType rF t@(StrTyLit _)
- | t == holeLit = RHole mempty
- | otherwise = rF listTyCon [rF charTyCon [] [] mempty] [] mempty
-
-holeLit :: TyLit
-holeLit = StrTyLit "$LH_RHOLE"
-
-data TyConv c tv r = TyConv
- { tcFVar :: TyVar -> RType c tv r
- , tcFTVar :: TyVar -> RTVar tv (RType c tv ())
- , tcFApp :: TyCon -> [RType c tv r] -> RType c tv r
- , tcFLit :: TyLit -> RType c tv r
- }
-
---------------------------------------------------------------------------------
--- | Converting to Fixpoint ----------------------------------------------------
---------------------------------------------------------------------------------
-
-
-instance Expression Var where
- expr = eVar
-
--- TODO: turn this into a map lookup?
-dataConReft :: DataCon -> [Symbol] -> Reft
-dataConReft c []
- | c == trueDataCon
- = predReft $ eProp vv_
- | c == falseDataCon
- = predReft $ PNot $ eProp vv_
-
-dataConReft c [x]
- | c == intDataCon
- = symbolReft x -- OLD (vv_, [RConc (PAtom Eq (EVar vv_) (EVar x))])
-dataConReft c _
- | not $ isBaseDataCon c
- = mempty
-dataConReft c xs
- = exprReft dcValue -- OLD Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)])
- where
- dcValue
- | null xs && null (dataConUnivTyVars c)
- = EVar $ symbol c
- | otherwise
- = mkEApp (dummyLoc $ symbol c) (eVar <$> xs)
-
-isBaseDataCon :: DataCon -> Bool
-isBaseDataCon c = and $ isBaseTy <$> dataConOrigArgTys c ++ dataConRepArgTys c
-
-isBaseTy :: Type -> Bool
-isBaseTy (TyVarTy _) = True
-isBaseTy (AppTy _ _) = False
-isBaseTy (TyConApp _ ts) = and $ isBaseTy <$> ts
-isBaseTy (FunTy _ _ _) = False
-isBaseTy (ForAllTy _ _) = False
-isBaseTy (LitTy _) = True
-isBaseTy (CastTy _ _) = False
-isBaseTy (CoercionTy _) = False
-
-
-dataConMsReft :: Reftable r => RType c tv r -> [Symbol] -> Reft
-dataConMsReft ty ys = subst su (rTypeReft (ignoreOblig $ ty_res trep))
- where
- trep = toRTypeRep ty
- xs = ty_binds trep
- ts = ty_args trep
- su = mkSubst $ [(x, EVar y) | ((x, _), y) <- zip (zip xs ts) ys]
-
---------------------------------------------------------------------------------
--- | Embedding RefTypes --------------------------------------------------------
---------------------------------------------------------------------------------
-
-type ToTypeable r = (Reftable r, PPrint r, SubsTy RTyVar (RRType ()) r, Reftable (RTProp RTyCon RTyVar r))
-
--- TODO: remove toType, generalize typeSort
-toType :: (ToTypeable r) => RRType r -> Type
-toType (RImpF x t t' r)
- = toType (RFun x t t' r)
-toType (RFun _ t t' _)
- = FunTy VisArg (toType t) (toType t') -- FIXME(adinapoli) Is 'VisArg' correct here?
-toType (RAllT a t _) | RTV α <- ty_var_value a
- = ForAllTy (Bndr α Required) (toType t)
-toType (RAllP _ t)
- = toType t
-toType (RVar (RTV α) _)
- = TyVarTy α
-toType (RApp (RTyCon {rtc_tc = c}) ts _ _)
- = TyConApp c (toType <$> filter notExprArg ts)
- where
- notExprArg (RExprArg _) = False
- notExprArg _ = True
-toType (RAllE _ _ t)
- = toType t
-toType (REx _ _ t)
- = toType t
-toType (RAppTy t (RExprArg _) _)
- = toType t
-toType (RAppTy t t' _)
- = AppTy (toType t) (toType t')
-toType t@(RExprArg _)
- = impossible Nothing $ "CANNOT HAPPEN: RefType.toType called with: " ++ show t
-toType (RRTy _ _ _ t)
- = toType t
-toType (RHole _)
- = LitTy holeLit
--- toType t
--- = {- impossible Nothing -} Prelude.error $ "RefType.toType cannot handle: " ++ show t
-
-{- | [NOTE:Hole-Lit]
-
-We use `toType` to convert RType to GHC.Type to expand any GHC
-related type-aliases, e.g. in Bare.Resolve.expandRTypeSynonyms.
-If the RType has a RHole then what to do?
-
-We, encode `RHole` as `LitTy "LH_HOLE"` -- which is a bit of
-a *hack*. The only saving grace is it is used *temporarily*
-and then swiftly turned back into an `RHole` via `ofType`
-(after GHC has done its business of expansion).
-
-Of course, we hope this doesn't break any GHC invariants!
-See issue #1476 and #1477
-
-The other option is to *not* use `toType` on things that have
-holes in them, but this seems worse, e.g. because you may define
-a plain GHC alias like:
-
- type ToNat a = a -> Nat
-
-and then you might write refinement types like:
-
- {-@ foo :: ToNat {v:_ | 0 <= v} @-}
-
-and we'd want to expand the above to
-
- {-@ foo :: {v:_ | 0 <= v} -> Nat @-}
-
-and then resolve the hole using the (GHC) type of `foo`.
-
--}
-
---------------------------------------------------------------------------------
--- | Annotations and Solutions -------------------------------------------------
---------------------------------------------------------------------------------
-
-rTypeSortedReft :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))
- => TCEmb TyCon -> RRType r -> SortedReft
-rTypeSortedReft emb t = RR (rTypeSort emb t) (rTypeReft t)
-
-rTypeSort :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))
- => TCEmb TyCon -> RRType r -> Sort
-rTypeSort tce = typeSort tce . toType
-
---------------------------------------------------------------------------------
-applySolution :: (Functor f) => FixSolution -> f SpecType -> f SpecType
---------------------------------------------------------------------------------
-applySolution = fmap . fmap . mapReft . appSolRefa
- where
- mapReft f (MkUReft (Reft (x, z)) p) = MkUReft (Reft (x, f z)) p
-
-appSolRefa :: Visitable t
- => M.HashMap KVar Expr -> t -> t
-appSolRefa s p = mapKVars f p
- where
- f k = Just $ M.lookupDefault PTop k s
-
---------------------------------------------------------------------------------
--- shiftVV :: Int -- SpecType -> Symbol -> SpecType
-shiftVV :: (TyConable c, F.Reftable (f Reft), Functor f)
- => RType c tv (f Reft) -> Symbol -> RType c tv (f Reft)
---------------------------------------------------------------------------------
-shiftVV t@(RApp _ ts rs r) vv'
- = t { rt_args = subst1 ts (rTypeValueVar t, EVar vv') }
- { rt_pargs = subst1 rs (rTypeValueVar t, EVar vv') }
- { rt_reft = (`F.shiftVV` vv') <$> r }
-
-shiftVV t@(RImpF _ _ _ r) vv'
- = t { rt_reft = (`F.shiftVV` vv') <$> r }
-
-shiftVV t@(RFun _ _ _ r) vv'
- = t { rt_reft = (`F.shiftVV` vv') <$> r }
-
-shiftVV t@(RAppTy _ _ r) vv'
- = t { rt_reft = (`F.shiftVV` vv') <$> r }
-
-shiftVV t@(RVar _ r) vv'
- = t { rt_reft = (`F.shiftVV` vv') <$> r }
-
-shiftVV t _
- = t -- errorstar $ "shiftVV: cannot handle " ++ showpp t
-
-
---------------------------------------------------------------------------------
--- |Auxiliary Stuff Used Elsewhere ---------------------------------------------
---------------------------------------------------------------------------------
-
--- MOVE TO TYPES
-instance (Show tv, Show ty) => Show (RTAlias tv ty) where
- show (RTA n as xs t) =
- printf "type %s %s %s = %s" (symbolString n)
- (unwords (show <$> as))
- (unwords (show <$> xs))
- (show t)
-
---------------------------------------------------------------------------------
--- | From Old Fixpoint ---------------------------------------------------------
---------------------------------------------------------------------------------
-typeSort :: TCEmb TyCon -> Type -> Sort
-typeSort tce = go
- where
- go :: Type -> Sort
- go t@(FunTy _ _ _) = typeSortFun tce t
- go τ@(ForAllTy _ _) = typeSortForAll tce τ
- -- go (TyConApp c τs) = fApp (tyConFTyCon tce c) (go <$> τs)
- go (TyConApp c τs)
- | isNewTyCon c
- , not (isRecursivenewTyCon c)
- = go (Ghc.newTyConInstRhs c τs)
- | otherwise
- = tyConFTyCon tce c (go <$> τs)
- go (AppTy t1 t2) = fApp (go t1) [go t2]
- go (TyVarTy tv) = tyVarSort tv
- go (CastTy t _) = go t
- go τ = FObj (typeUniqueSymbol τ)
-
-tyConFTyCon :: TCEmb TyCon -> TyCon -> [Sort] -> Sort
-tyConFTyCon tce c ts = case tceLookup c tce of
- Just (t, WithArgs) -> t
- Just (t, NoArgs) -> fApp t ts
- Nothing -> fApp (fTyconSort niTc) ts
- where
- niTc = symbolNumInfoFTyCon (dummyLoc $ tyConName c) (isNumCls c) (isFracCls c)
- -- oldRes = F.notracepp _msg $ M.lookupDefault def c tce
- -- _msg = "tyConFTyCon c = " ++ show c ++ "default " ++ show (def, TC.isFamInstTyCon c)
-
-tyVarSort :: TyVar -> Sort
-tyVarSort = FObj . symbol
-
-typeUniqueSymbol :: Type -> Symbol
-typeUniqueSymbol = symbol . GM.typeUniqueString
-
-typeSortForAll :: TCEmb TyCon -> Type -> Sort
-typeSortForAll tce τ = F.notracepp ("typeSortForall " ++ showpp τ) $ genSort sbody
- where
- sbody = typeSort tce tbody
- genSort t = foldl' (flip FAbs) (sortSubst su t) [i..n+i-1]
- (as, tbody) = F.notracepp ("splitForallTys" ++ GM.showPpr τ) (splitForAllTys τ)
- su = M.fromList $ zip sas (FVar <$> [i..])
- sas = symbol <$> as
- n = length as
- i = sortAbs sbody + 1
-
--- RJ: why not make this the Symbolic instance?
-tyConName :: TyCon -> Symbol
-tyConName c
- | listTyCon == c = listConName
- | TC.isTupleTyCon c = tupConName
- | otherwise = symbol c
-
-typeSortFun :: TCEmb TyCon -> Type -> Sort
-typeSortFun tce t = mkFFunc 0 sos
- where
- sos = typeSort tce <$> τs
- τs = grabArgs [] t
-
-grabArgs :: [Type] -> Type -> [Type]
-grabArgs τs (FunTy _ τ1 τ2)
- | Just a <- stringClassArg τ1
- = grabArgs τs (mapType (\t -> if t == a then stringTy else t) τ2)
- | not ( F.notracepp ("isNonArg: " ++ GM.showPpr τ1) $ isNonValueTy τ1)
- = grabArgs (τ1:τs) τ2
- | otherwise
- = grabArgs τs τ2
-grabArgs τs τ
- = reverse (τ:τs)
-
-isNonValueTy :: Type -> Bool
-isNonValueTy = GM.isPredType
-
-
-expandProductType :: (PPrint r, Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, Reftable (RTProp RTyCon RTyVar r))
- => Var -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
-expandProductType x t
- | isTrivial = t
- | otherwise = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_refts = rs'}
- where
- isTrivial = ofType (varType x) == toRSort t
- τs = fst $ splitFunTys $ snd $ splitForAllTys $ toType t
- trep = toRTypeRep t
- (xs',ts',rs') = unzip3 $ concatMap mkProductTy $ zip4 τs (ty_binds trep) (ty_args trep) (ty_refts trep)
-
--- splitFunTys :: Type -> ([Type], Type)
-
-
-mkProductTy :: (Monoid t, Monoid r)
- => (Type, Symbol, RType RTyCon RTyVar r, t)
- -> [(Symbol, RType RTyCon RTyVar r, t)]
-mkProductTy (τ, x, t, r) = maybe [(x, t, r)] f $ deepSplitProductType_maybe menv τ
- where
- f = map ((dummySymbol, , mempty) . ofType . fst) . third4
- menv = (emptyFamInstEnv, emptyFamInstEnv)
-
------------------------------------------------------------------------------------------
--- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum)
------------------------------------------------------------------------------------------
-classBinds :: TCEmb TyCon -> SpecType -> [(Symbol, SortedReft)]
-classBinds _ (RApp c ts _ _)
- | isFracCls c
- = [(symbol a, trueSortedReft FFrac) | (RVar a _) <- ts]
- | isNumCls c
- = [(symbol a, trueSortedReft FNum) | (RVar a _) <- ts]
-classBinds emb (RApp c [_, _, (RVar a _), t] _ _)
- | isEqual c
- = [(symbol a, rTypeSortedReft emb t)]
-classBinds emb ty@(RApp c [_, (RVar a _), t] _ _)
- | isEqualityConstr ty
- = [(symbol a, rTypeSortedReft emb t)]
- | otherwise
- = notracepp ("CLASSBINDS-0: " ++ showpp c) []
-classBinds _ t
- = notracepp ("CLASSBINDS-1: " ++ showpp (toType t, isEqualityConstr t)) []
-
-isEqualityConstr :: SpecType -> Bool
-isEqualityConstr (toType -> ty) = Ghc.isEqPred ty || Ghc.isEqPrimPred ty
-
---------------------------------------------------------------------------------
--- | Termination Predicates ----------------------------------------------------
---------------------------------------------------------------------------------
-
-makeNumEnv :: (Foldable t, TyConable c) => t (RType c b t1) -> [b]
-makeNumEnv = concatMap go
- where
- go (RApp c ts _ _) | isNumCls c || isFracCls c = [ a | (RVar a _) <- ts]
- go _ = []
-
-isDecreasing :: S.HashSet TyCon -> [RTyVar] -> SpecType -> Bool
-isDecreasing autoenv _ (RApp c _ _ _)
- = isJust (sizeFunction (rtc_info c)) -- user specified size or
- || isSizeable autoenv tc
- where tc = rtc_tc c
-isDecreasing _ cenv (RVar v _)
- = v `elem` cenv
-isDecreasing _ _ _
- = False
-
-makeDecrType :: Symbolic a
- => S.HashSet TyCon
- -> [(a, (Symbol, RType RTyCon t (UReft Reft)))]
- -> Either (Symbol, RType RTyCon t (UReft Reft)) String
-makeDecrType autoenv = mkDType autoenv [] []
-
-mkDType :: Symbolic a
- => S.HashSet TyCon
- -> [(Symbol, Symbol, Symbol -> Expr)]
- -> [Expr]
- -> [(a, (Symbol, RType RTyCon t (UReft Reft)))]
- -> Either (Symbol, RType RTyCon t (UReft Reft)) String
-mkDType autoenv xvs acc [(v, (x, t))]
- = Left ((x, ) $ t `strengthen` tr)
- where
- tr = uTop $ Reft (vv, pOr (r:acc))
- r = cmpLexRef xvs (v', vv, f)
- v' = symbol v
- f = mkDecrFun autoenv t
- vv = "vvRec"
-
-mkDType autoenv xvs acc ((v, (x, t)):vxts)
- = mkDType autoenv ((v', x, f):xvs) (r:acc) vxts
- where
- r = cmpLexRef xvs (v', x, f)
- v' = symbol v
- f = mkDecrFun autoenv t
-
-
-mkDType _ _ _ _
- = Right "RefType.mkDType called on invalid input"
-
-isSizeable :: S.HashSet TyCon -> TyCon -> Bool
-isSizeable autoenv tc = S.member tc autoenv -- TC.isAlgTyCon tc -- && TC.isRecursiveTyCon tc
-
-mkDecrFun :: S.HashSet TyCon -> RType RTyCon t t1 -> Symbol -> Expr
-mkDecrFun autoenv (RApp c _ _ _)
- | Just f <- szFun <$> sizeFunction (rtc_info c)
- = f
- | isSizeable autoenv $ rtc_tc c
- = \v -> F.mkEApp lenLocSymbol [F.EVar v]
-mkDecrFun _ (RVar _ _)
- = EVar
-mkDecrFun _ _
- = panic Nothing "RefType.mkDecrFun called on invalid input"
-
--- | [NOTE]: THIS IS WHERE THE TERMINATION METRIC REFINEMENTS ARE CREATED.
-cmpLexRef :: [(t1, t1, t1 -> Expr)] -> (t, t, t -> Expr) -> Expr
-cmpLexRef vxs (v, x, g)
- = pAnd $ (PAtom Lt (g x) (g v)) : (PAtom Ge (g x) zero)
- : [PAtom Eq (f y) (f z) | (y, z, f) <- vxs]
- ++ [PAtom Ge (f y) zero | (y, _, f) <- vxs]
- where zero = ECon $ I 0
-
-makeLexRefa :: [Located Expr] -> [Located Expr] -> UReft Reft
-makeLexRefa es' es = uTop $ Reft (vv, PIff (EVar vv) $ pOr rs)
- where
- rs = makeLexReft [] [] (val <$> es) (val <$> es')
- vv = "vvRec"
-
-makeLexReft :: [(Expr, Expr)] -> [Expr] -> [Expr] -> [Expr] -> [Expr]
-makeLexReft _ acc [] []
- = acc
-makeLexReft old acc (e:es) (e':es')
- = makeLexReft ((e,e'):old) (r:acc) es es'
- where
- r = pAnd $ (PAtom Lt e' e)
- : (PAtom Ge e' zero)
- : [PAtom Eq o' o | (o,o') <- old]
- ++ [PAtom Ge o' zero | (_,o') <- old]
- zero = ECon $ I 0
-makeLexReft _ _ _ _
- = panic Nothing "RefType.makeLexReft on invalid input"
-
---------------------------------------------------------------------------------
-mkTyConInfo :: TyCon -> VarianceInfo -> VarianceInfo -> Maybe SizeFun -> TyConInfo
-mkTyConInfo c userTv userPv f = TyConInfo tcTv userPv f
- where
- tcTv = if null userTv then defTv else userTv
- defTv = makeTyConVariance c
-
-
-makeTyConVariance :: TyCon -> VarianceInfo
-makeTyConVariance c = varSignToVariance <$> tvs
- where
- tvs = GM.tyConTyVarsDef c
-
- varsigns = if TC.isTypeSynonymTyCon c
- then go True (fromJust $ TC.synTyConRhs_maybe c)
- else L.nub $ concatMap goDCon $ TC.tyConDataCons c
-
- varSignToVariance v = case filter (\p -> GM.showPpr (fst p) == GM.showPpr v) varsigns of
- [] -> Invariant
- [(_, b)] -> if b then Covariant else Contravariant
- _ -> Bivariant
-
-
- goDCon dc = concatMap (go True) (DataCon.dataConOrigArgTys dc)
-
- go pos (FunTy _ t1 t2) = go (not pos) t1 ++ go pos t2
- go pos (ForAllTy _ t) = go pos t
- go pos (TyVarTy v) = [(v, pos)]
- go pos (AppTy t1 t2) = go pos t1 ++ go pos t2
- go pos (TyConApp c' ts)
- | c == c'
- = []
-
--- NV fix that: what happens if we have mutually recursive data types?
--- now just provide "default" Bivariant for mutually rec types.
--- but there should be a finer solution
- | mutuallyRecursive c c'
- = concatMap (goTyConApp pos Bivariant) ts
- | otherwise
- = concat $ zipWith (goTyConApp pos) (makeTyConVariance c') ts
-
- go _ (LitTy _) = []
- go _ (CoercionTy _) = []
- go pos (CastTy t _) = go pos t
-
- goTyConApp _ Invariant _ = []
- goTyConApp pos Bivariant t = goTyConApp pos Contravariant t ++ goTyConApp pos Covariant t
- goTyConApp pos Covariant t = go pos t
- goTyConApp pos Contravariant t = go (not pos) t
-
- mutuallyRecursive c c' = c `S.member` (dataConsOfTyCon c')
-
-
-dataConsOfTyCon :: TyCon -> S.HashSet TyCon
-dataConsOfTyCon = dcs S.empty
- where
- dcs vis c = mconcat $ go vis <$> [t | dc <- TC.tyConDataCons c, t <- DataCon.dataConOrigArgTys dc]
- go vis (FunTy _ t1 t2) = go vis t1 `S.union` go vis t2
- go vis (ForAllTy _ t) = go vis t
- go _ (TyVarTy _) = S.empty
- go vis (AppTy t1 t2) = go vis t1 `S.union` go vis t2
- go vis (TyConApp c ts)
- | c `S.member` vis
- = S.empty
- | otherwise
- = (S.insert c $ mconcat $ go vis <$> ts) `S.union` dcs (S.insert c vis) c
- go _ (LitTy _) = S.empty
- go _ (CoercionTy _) = S.empty
- go vis (CastTy t _) = go vis t
-
---------------------------------------------------------------------------------
--- | Printing Refinement Types -------------------------------------------------
---------------------------------------------------------------------------------
-
-instance Show RTyVar where
- show = showpp
-
-instance PPrint (UReft r) => Show (UReft r) where
- show = showpp
-
-instance PPrint DataDecl where
- pprintTidy k dd = "data" <+> pprint (tycName dd) <+> ppMbSizeFun (tycSFun dd) <+> pprint (tycTyVars dd) <+> "="
- $+$ nest 4 (vcat $ [ "|" <+> pprintTidy k c | c <- tycDCons dd ])
-
-instance PPrint DataCtor where
- -- pprintTidy k (DataCtor c as _ xts Nothing) = pprintTidy k c <+> dcolon ppVars as <+> braces (ppFields k ", " xts)
- -- pprintTidy k (DataCtor c as ths xts (Just t)) = pprintTidy k c <+> dcolon <+> ppVars as <+> ppThetas ths <+> (ppFields k " ->" xts) <+> "->" <+> pprintTidy k t
- pprintTidy k (DataCtor c as ths xts t) = pprintTidy k c <+> dcolon <+> ppVars k as <+> ppThetas ths <+> (ppFields k " ->" xts) <+> "->" <+> res
- where
- res = maybe "*" (pprintTidy k) t
- ppThetas [] = empty
- ppThetas ts = parens (hcat $ punctuate ", " (pprintTidy k <$> ts)) <+> "=>"
-
-
-ppVars :: (PPrint a) => Tidy -> [a] -> Doc
-ppVars k as = "forall" <+> hcat (punctuate " " (F.pprintTidy k <$> as)) <+> "."
-
-ppFields :: (PPrint k, PPrint v) => Tidy -> Doc -> [(k, v)] -> Doc
-ppFields k sep kvs = hcat $ punctuate sep (F.pprintTidy k <$> kvs)
-
-ppMbSizeFun :: Maybe SizeFun -> Doc
-ppMbSizeFun Nothing = ""
-ppMbSizeFun (Just z) = F.pprint z
-
--- instance PPrint DataCtor where
- -- pprintTidy k (DataCtor c xts t) =
- -- pprintTidy k c <+> text "::" <+> (hsep $ punctuate (text "->")
- -- ((pprintTidy k <$> xts) ++ [pprintTidy k t]))
-
--- ppHack :: (?callStack :: CallStack) => a -> b
--- ppHack _ = errorstar "OOPS"
-
-instance PPrint (RType c tv r) => Show (RType c tv r) where
- show = showpp
-
-instance PPrint (RTProp c tv r) => Show (RTProp c tv r) where
- show = showpp
-
-
--------------------------------------------------------------------------------
--- | tyVarsPosition t returns the type variables appearing
--- | (in positive positions, in negative positions, in undetermined positions)
--- | undetermined positions are due to type constructors and type application
--------------------------------------------------------------------------------
-tyVarsPosition :: RType RTyCon tv r -> Positions tv
-tyVarsPosition = go (Just True)
- where
- go p (RVar t _) = report p t
- go p (RFun _ t1 t2 _) = go (flip p) t1 <> go p t2
- go p (RImpF _ t1 t2 _) = go (flip p) t1 <> go p t2
- go p (RAllT _ t _) = go p t
- go p (RAllP _ t) = go p t
- go p (RApp c ts _ _) = mconcat (zipWith go (getPosition p <$> varianceTyArgs (rtc_info c)) ts)
- go p (RAllE _ t1 t2) = go p t1 <> go p t2
- go p (REx _ t1 t2) = go p t1 <> go p t2
- go _ (RExprArg _) = mempty
- go p (RAppTy t1 t2 _) = go p t1 <> go p t2
- go p (RRTy _ _ _ t) = go p t
- go _ (RHole _) = mempty
-
- getPosition :: Maybe Bool -> Variance -> Maybe Bool
- getPosition b Contravariant = not <$> b
- getPosition b _ = b
-
- report Nothing v = (Pos [] [] [v])
- report (Just True) v = (Pos [v] [] [])
- report (Just False) v = (Pos [] [v] [])
- flip = fmap not
-
-data Positions a = Pos {ppos :: [a], pneg :: [a], punknown :: [a]}
-
-instance Monoid (Positions a) where
- mempty = Pos [] [] []
-instance Semigroup (Positions a) where
- (Pos x1 x2 x3) <> (Pos y1 y2 y3) = Pos (x1 ++ y1) (x2 ++ y2) (x3 ++ y3)
diff --git a/src/Language/Haskell/Liquid/Types/Specs.hs b/src/Language/Haskell/Liquid/Types/Specs.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Types/Specs.hs
+++ /dev/null
@@ -1,803 +0,0 @@
--- | This module contains the top-level structures that hold
--- information about specifications.
-
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards #-}
-
-module Language.Haskell.Liquid.Types.Specs (
- -- * Different types of specifications
- -- $differentSpecTypes
- -- * TargetInfo
- -- $targetInfo
- TargetInfo(..)
- -- * Gathering information about a module
- , TargetSrc(..)
- -- * TargetSpec
- -- $targetSpec
- , TargetSpec(..)
- -- * BareSpec
- -- $bareSpec
- , BareSpec(..)
- -- * LiftedSpec
- -- $liftedSpec
- , LiftedSpec(..)
- -- * Tracking dependencies
- -- $trackingDeps
- , StableModule(..)
- , toStableModule
- , renderModule
- , TargetDependencies(..)
- , dropDependency
- -- * Predicates on spec types
- -- $predicates
- , isPLEVar
- , isExportedVar
- -- * Other types
- , QImports(..)
- , Spec(..)
- , GhcSpecVars(..)
- , GhcSpecSig(..)
- , GhcSpecNames(..)
- , GhcSpecTerm(..)
- , GhcSpecRefl(..)
- , GhcSpecLaws(..)
- , GhcSpecData(..)
- , GhcSpecQual(..)
- , BareDef
- , BareMeasure
- , SpecMeasure
- , VarOrLocSymbol
- , LawInstance(..)
- -- * Legacy data structures
- -- $legacyDataStructures
- , GhcSrc(..)
- , GhcSpec(..)
- -- * Provisional compatibility exports & optics
- -- $provisionalBackCompat
- , targetSrcIso
- , targetSpecGetter
- , bareSpecIso
- , liftedSpecGetter
- , unsafeFromLiftedSpec
- ) where
-
-import Optics
-import GHC.Generics hiding (to, moduleName)
-import Data.Binary
-import qualified Language.Fixpoint.Types as F
-import Language.Fixpoint.Misc (sortNub)
-import Data.Hashable
-import qualified Data.HashSet as S
-import Data.HashSet (HashSet)
-import qualified Data.HashMap.Strict as M
-import Data.HashMap.Strict (HashMap)
-import Language.Haskell.Liquid.Types.Types
-import Language.Haskell.Liquid.Types.Generics
-import Language.Haskell.Liquid.Types.Variance
-import Language.Haskell.Liquid.Types.Bounds
-import Language.Haskell.Liquid.GHC.API
-import Language.Haskell.Liquid.GHC.Types
-import Text.PrettyPrint.HughesPJ (text, (<+>))
-
-
-{- $differentSpecTypes
-
-There are different types or \"flavours\" for a specification, depending on its lifecycle. The main goal
-is always the same, i.e. refining the Haskell types and produce a final statement (i.e. safe or unsafe)
-about the input program. In order to do so, a /specification/ is transformed in the way described by this
-picture:
-
-@
- +---------------+ +-------------------+
- | BareSpec | | | checked by liquid/liquidOne
- | | ------------| TargetSpec |----------------------------- ..
- |(input module) | / | |
- +---------------+ makeTargetSpec / +-------------------+
- + -----------------/
- +---------------+ \\ +-------------------+
- | {LiftedSpec} | \\ | | serialised on disk
- | | -------------| LiftedSpec |----------------------------- ..
- |(dependencies) | | |
- +---------------+ +-------------------+
- ^ |
- | used-as |
- +----------------------------------------------------+
-@
-
-More specifically, we distinguish:
-
-* 'BareSpec' - is the specification obtained by parsing the Liquid annotations of the input Haskell file.
- It typically contains information about the associated input Haskell module, with the exceptions of
- /assumptions/ that can refer to functions defined in other modules.
-
-* 'LiftedSpec' - is the specification we obtain by \"lifting\" the 'BareSpec'. Most importantly, a
- 'LiftedSpec' gets serialised on disk and becomes a /dependency/ for the verification of other 'BareSpec's.
-
- Lifting in this context consist of:
-
- 1. Perform name-resolution (e.g. make all the relevant GHC's 'Var's qualified, resolve GHC's 'Name's, etc);
- 2. Strip the final 'LiftedSpec' with information which are relevant (read: local) to just the input
- 'BareSpec'. An example would be /local signatures/, used to annotate internal, auxiliary functions
- within a 'Module';
- 3. Strip termination checks, which are /required/ (if specified) for a 'BareSpec' but not for the
- 'LiftedSpec'.
-
-* 'TargetSpec' - is the specification we /actually use for refinement/, and is conceptually an
- \"augmented\" 'BareSpec'. You can create a 'TargetSpec' by calling 'makeTargetSpec'.
-
-In order to produce these spec types we have to gather information about the module being compiled by using
-the GHC API and retain enough context of the compiled 'Module' in order to be able to construct the types
-introduced aboves. The rest of this module introduced also these intermediate structures.
--}
-
--- $targetInfo
--- The following is the overall type for /specifications/ obtained from
--- parsing the target source and dependent libraries.
--- /IMPORTANT/: A 'TargetInfo' is what is /checked/ by LH itself and it /NEVER/ contains the 'LiftedSpec',
--- because the checking happens only on the 'BareSpec' of the target module.
-data TargetInfo = TargetInfo
- { giSrc :: !TargetSrc
- -- ^ The 'TargetSrc' of the module being checked.
- , giSpec :: !TargetSpec
- -- ^ The 'TargetSpec' of the module being checked.
- }
-
-instance HasConfig TargetInfo where
- getConfig = getConfig . giSpec
-
--- | The 'TargetSrc' type is a collection of all the things we know about a module being currently
--- checked. It include things like the name of the module, the list of 'CoreBind's,
--- the 'TyCon's declared in this module (that includes 'TyCon's for classes), typeclass instances
--- and so and so forth. It might be consider a sort of 'ModGuts' embellished with LH-specific
--- information (for example, 'giDefVars' are populated with datacons from the module plus the
--- let vars derived from the A-normalisation).
-data TargetSrc = TargetSrc
- { giIncDir :: !FilePath -- ^ Path for LH include/prelude directory
- , giTarget :: !FilePath -- ^ Source file for module
- , giTargetMod :: !ModName -- ^ Name for module
- , giCbs :: ![CoreBind] -- ^ Source Code
- , gsTcs :: ![TyCon] -- ^ All used Type constructors
- , gsCls :: !(Maybe [ClsInst]) -- ^ Class instances?
- , giDerVars :: !(HashSet Var) -- ^ Binders created by GHC eg dictionaries
- , giImpVars :: ![Var] -- ^ Binders that are _read_ in module (but not defined?)
- , giDefVars :: ![Var] -- ^ (Top-level) binders that are _defined_ in module
- , giUseVars :: ![Var] -- ^ Binders that are _read_ in module
- , gsExports :: !(HashSet StableName) -- ^ `Name`s exported by the module being verified
- , gsFiTcs :: ![TyCon] -- ^ Family instance TyCons
- , gsFiDcs :: ![(F.Symbol, DataCon)] -- ^ Family instance DataCons
- , gsPrimTcs :: ![TyCon] -- ^ Primitive GHC TyCons (from TysPrim.primTyCons)
- , gsQualImps :: !QImports -- ^ Map of qualified imports
- , gsAllImps :: !(HashSet F.Symbol) -- ^ Set of _all_ imported modules
- , gsTyThings :: ![TyThing] -- ^ All the @TyThing@s known to GHC
- }
-
--- | 'QImports' is a map of qualified imports.
-data QImports = QImports
- { qiModules :: !(S.HashSet F.Symbol) -- ^ All the modules that are imported qualified
- , qiNames :: !(M.HashMap F.Symbol [F.Symbol]) -- ^ Map from qualification to full module name
- } deriving Show
-
--- $targetSpec
-
--- | A 'TargetSpec' is what we /actually check via LiquidHaskell/. It is created as part of 'mkTargetSpec'
--- alongside the 'LiftedSpec'. It shares a similar structure with a 'BareSpec', but manipulates and
--- transforms the data in preparation to the checking process.
-data TargetSpec = TargetSpec
- { gsSig :: !GhcSpecSig
- , gsQual :: !GhcSpecQual
- , gsData :: !GhcSpecData
- , gsName :: !GhcSpecNames
- , gsVars :: !GhcSpecVars
- , gsTerm :: !GhcSpecTerm
- , gsRefl :: !GhcSpecRefl
- , gsLaws :: !GhcSpecLaws
- , gsImps :: ![(F.Symbol, F.Sort)] -- ^ Imported Environment
- , gsConfig :: !Config
- }
-
-instance HasConfig TargetSpec where
- getConfig = gsConfig
-
--- | The collection of GHC 'Var's that a 'TargetSpec' needs to verify (or skip).
-data GhcSpecVars = SpVar
- { gsTgtVars :: ![Var] -- ^ Top-level Binders To Verify (empty means ALL binders)
- , gsIgnoreVars :: !(S.HashSet Var) -- ^ Top-level Binders To NOT Verify (empty means ALL binders)
- , gsLvars :: !(S.HashSet Var) -- ^ Variables that should be checked "lazily" in the environment they are used
- , gsCMethods :: ![Var] -- ^ Refined Class methods
- }
-
-data GhcSpecQual = SpQual
- { gsQualifiers :: ![F.Qualifier] -- ^ Qualifiers in Source/Spec files e.g tests/pos/qualTest.hs
- , gsRTAliases :: ![F.Located SpecRTAlias] -- ^ Refinement type aliases (only used for qualifiers)
- }
-
-data GhcSpecSig = SpSig
- { gsTySigs :: ![(Var, LocSpecType)] -- ^ Asserted Reftypes
- , gsAsmSigs :: ![(Var, LocSpecType)] -- ^ Assumed Reftypes
- , gsRefSigs :: ![(Var, LocSpecType)] -- ^ Reflected Reftypes
- , gsInSigs :: ![(Var, LocSpecType)] -- ^ Auto generated Signatures
- , gsNewTypes :: ![(TyCon, LocSpecType)] -- ^ Mapping of 'newtype' type constructors with their refined types.
- , gsDicts :: !(DEnv Var LocSpecType) -- ^ Refined Classes from Instances
- , gsMethods :: ![(Var, MethodType LocSpecType)] -- ^ Refined Classes from Classes
- , gsTexprs :: ![(Var, LocSpecType, [F.Located F.Expr])] -- ^ Lexicographically ordered expressions for termination
- }
-
-data GhcSpecData = SpData
- { gsCtors :: ![(Var, LocSpecType)] -- ^ Data Constructor Measure Sigs
- , gsMeas :: ![(F.Symbol, LocSpecType)] -- ^ Measure Types eg. len :: [a] -> Int
- , gsInvariants :: ![(Maybe Var, LocSpecType)] -- ^ Data type invariants from measure definitions, e.g forall a. {v: [a] | len(v) >= 0}
- , gsIaliases :: ![(LocSpecType, LocSpecType)] -- ^ Data type invariant aliases
- , gsMeasures :: ![Measure SpecType DataCon] -- ^ Measure definitions
- , gsUnsorted :: ![UnSortedExpr]
- }
-
-data GhcSpecNames = SpNames
- { gsFreeSyms :: ![(F.Symbol, Var)] -- ^ List of `Symbol` free in spec and corresponding GHC var, eg. (Cons, Cons#7uz) from tests/pos/ex1.hs
- , gsDconsP :: ![F.Located DataCon] -- ^ Predicated Data-Constructors, e.g. see tests/pos/Map.hs
- , gsTconsP :: ![TyConP] -- ^ Predicated Type-Constructors, e.g. see tests/pos/Map.hs
- , gsTcEmbeds :: !(F.TCEmb TyCon) -- ^ Embedding GHC Tycons into fixpoint sorts e.g. "embed Set as Set_set" from include/Data/Set.spec
- , gsADTs :: ![F.DataDecl] -- ^ ADTs extracted from Haskell 'data' definitions
- , gsTyconEnv :: !TyConMap
- }
-
-data GhcSpecTerm = SpTerm
- { gsStTerm :: !(S.HashSet Var) -- ^ Binders to CHECK by structural termination
- , gsAutosize :: !(S.HashSet TyCon) -- ^ Binders to IGNORE during termination checking
- , gsLazy :: !(S.HashSet Var) -- ^ Binders to IGNORE during termination checking
- , gsFail :: !(S.HashSet (F.Located Var)) -- ^ Binders to fail type checking
- , gsDecr :: ![(Var, [Int])] -- ^ Lexicographic order of decreasing args (DEPRECATED)
- , gsNonStTerm :: !(S.HashSet Var) -- ^ Binders to CHECK using REFINEMENT-TYPES/termination metrics
- }
-
-data GhcSpecRefl = SpRefl
- { gsAutoInst :: !(M.HashMap Var (Maybe Int)) -- ^ Binders to USE PLE
- , gsHAxioms :: ![(Var, LocSpecType, F.Equation)] -- ^ Lifted definitions
- , gsImpAxioms :: ![F.Equation] -- ^ Axioms from imported reflected functions
- , gsMyAxioms :: ![F.Equation] -- ^ Axioms from my reflected functions
- , gsReflects :: ![Var] -- ^ Binders for reflected functions
- , gsLogicMap :: !LogicMap
- , gsWiredReft :: ![Var]
- , gsRewrites :: S.HashSet (F.Located Var)
- , gsRewritesWith :: M.HashMap Var [Var]
- }
-
-data GhcSpecLaws = SpLaws
- { gsLawDefs :: !([(Class, [(Var, LocSpecType)])])
- , gsLawInst :: ![LawInstance]
- }
-
-data LawInstance = LawInstance
- { lilName :: Class
- , liSupers :: [LocSpecType]
- , lilTyArgs :: [LocSpecType]
- , lilEqus :: [(VarOrLocSymbol, (VarOrLocSymbol, Maybe LocSpecType))]
- , lilPos :: SrcSpan
- }
-
-type VarOrLocSymbol = Either Var LocSymbol
-type BareMeasure = Measure LocBareType F.LocSymbol
-type BareDef = Def LocBareType F.LocSymbol
-type SpecMeasure = Measure LocSpecType DataCon
-
--- $bareSpec
-
--- | A 'BareSpec' is the spec we derive by parsing the Liquid Haskell annotations of a single file. As
--- such, it contains things which are relevant for validation and lifting; it contains things like
--- the pragmas the user defined, the termination condition (if termination-checking is enabled) and so
--- on and so forth. /Crucially/, as a 'BareSpec' is still subject to \"preflight checks\", it may contain
--- duplicates (e.g. duplicate measures, duplicate type declarations etc.) and therefore most of the fields
--- for a 'BareSpec' are lists, so that we can report these errors to the end user: it would be an error
--- to silently ignore the duplication and leave the duplicate resolution to whichever 'Eq' instance is
--- implemented for the relevant field.
---
--- Also, a 'BareSpec' has not yet been subject to name resolution, so it may refer
--- to undefined or out-of-scope entities.
-newtype BareSpec =
- MkBareSpec { getBareSpec :: Spec LocBareType F.LocSymbol }
- deriving (Generic, Show, Semigroup, Monoid, Binary)
-
--- | A generic 'Spec' type, polymorphic over the inner choice of type and binder.
-data Spec ty bndr = Spec
- { measures :: ![Measure ty bndr] -- ^ User-defined properties for ADTs
- , impSigs :: ![(F.Symbol, F.Sort)] -- ^ Imported variables types
- , expSigs :: ![(F.Symbol, F.Sort)] -- ^ Exported variables types
- , asmSigs :: ![(F.LocSymbol, ty)] -- ^ Assumed (unchecked) types; including reflected signatures
- , sigs :: ![(F.LocSymbol, ty)] -- ^ Imported functions and types
- , localSigs :: ![(F.LocSymbol, ty)] -- ^ Local type signatures
- , reflSigs :: ![(F.LocSymbol, ty)] -- ^ Reflected type signatures
- , invariants :: ![(Maybe F.LocSymbol, ty)] -- ^ Data type invariants; the Maybe is the generating measure
- , ialiases :: ![(ty, ty)] -- ^ Data type invariants to be checked
- , imports :: ![F.Symbol] -- ^ Loaded spec module names
- , dataDecls :: ![DataDecl] -- ^ Predicated data definitions
- , newtyDecls :: ![DataDecl] -- ^ Predicated new type definitions
- , includes :: ![FilePath] -- ^ Included qualifier files
- , aliases :: ![F.Located (RTAlias F.Symbol BareType)] -- ^ RefType aliases
- , ealiases :: ![F.Located (RTAlias F.Symbol F.Expr)] -- ^ Expression aliases
- , embeds :: !(F.TCEmb F.LocSymbol) -- ^ GHC-Tycon-to-fixpoint Tycon map
- , qualifiers :: ![F.Qualifier] -- ^ Qualifiers in source/spec files
- , decr :: ![(F.LocSymbol, [Int])] -- ^ Information on decreasing arguments
- , lvars :: !(S.HashSet F.LocSymbol) -- ^ Variables that should be checked in the environment they are used
- , lazy :: !(S.HashSet F.LocSymbol) -- ^ Ignore Termination Check in these Functions
- , rewrites :: !(S.HashSet F.LocSymbol) -- ^ Theorems turned into rewrite rules
- , rewriteWith :: !(M.HashMap F.LocSymbol [F.LocSymbol]) -- ^ Definitions using rewrite rules
- , fails :: !(S.HashSet F.LocSymbol) -- ^ These Functions should be unsafe
- , reflects :: !(S.HashSet F.LocSymbol) -- ^ Binders to reflect
- , autois :: !(M.HashMap F.LocSymbol (Maybe Int)) -- ^ Automatically instantiate axioms in these Functions with maybe specified fuel
- , hmeas :: !(S.HashSet F.LocSymbol) -- ^ Binders to turn into measures using haskell definitions
- , hbounds :: !(S.HashSet F.LocSymbol) -- ^ Binders to turn into bounds using haskell definitions
- , inlines :: !(S.HashSet F.LocSymbol) -- ^ Binders to turn into logic inline using haskell definitions
- , ignores :: !(S.HashSet F.LocSymbol) -- ^ Binders to ignore during checking; that is DON't check the corebind.
- , autosize :: !(S.HashSet F.LocSymbol) -- ^ Type Constructors that get automatically sizing info
- , pragmas :: ![F.Located String] -- ^ Command-line configurations passed in through source
- , cmeasures :: ![Measure ty ()] -- ^ Measures attached to a type-class
- , imeasures :: ![Measure ty bndr] -- ^ Mappings from (measure,type) -> measure
- , classes :: ![RClass ty] -- ^ Refined Type-Classes
- , claws :: ![RClass ty] -- ^ Refined Type-Classe Laws
- , termexprs :: ![(F.LocSymbol, [F.Located F.Expr])] -- ^ Terminating Conditions for functions
- , rinstance :: ![RInstance ty]
- , ilaws :: ![RILaws ty]
- , dvariance :: ![(F.LocSymbol, [Variance])] -- ^ ? Where do these come from ?!
- , bounds :: !(RRBEnv ty)
- , defs :: !(M.HashMap F.LocSymbol F.Symbol) -- ^ Temporary (?) hack to deal with dictionaries in specifications
- -- see tests/pos/NatClass.hs
- , axeqs :: ![F.Equation] -- ^ Equalities used for Proof-By-Evaluation
- } deriving (Generic, Show)
-
-instance Binary (Spec LocBareType F.LocSymbol)
-
-instance (Show ty, Show bndr, F.PPrint ty, F.PPrint bndr) => F.PPrint (Spec ty bndr) where
- pprintTidy k sp = text "dataDecls = " <+> pprintTidy k (dataDecls sp)
-
--- /NOTA BENE/: These instances below are considered legacy, because merging two 'Spec's together doesn't
--- really make sense, and we provide this only for legacy purposes.
-instance Semigroup (Spec ty bndr) where
- s1 <> s2
- = Spec { measures = measures s1 ++ measures s2
- , impSigs = impSigs s1 ++ impSigs s2
- , expSigs = expSigs s1 ++ expSigs s2
- , asmSigs = asmSigs s1 ++ asmSigs s2
- , sigs = sigs s1 ++ sigs s2
- , localSigs = localSigs s1 ++ localSigs s2
- , reflSigs = reflSigs s1 ++ reflSigs s2
- , invariants = invariants s1 ++ invariants s2
- , ialiases = ialiases s1 ++ ialiases s2
- , imports = sortNub $ imports s1 ++ imports s2
- , dataDecls = dataDecls s1 ++ dataDecls s2
- , newtyDecls = newtyDecls s1 ++ newtyDecls s2
- , includes = sortNub $ includes s1 ++ includes s2
- , aliases = aliases s1 ++ aliases s2
- , ealiases = ealiases s1 ++ ealiases s2
- , qualifiers = qualifiers s1 ++ qualifiers s2
- , decr = decr s1 ++ decr s2
- , pragmas = pragmas s1 ++ pragmas s2
- , cmeasures = cmeasures s1 ++ cmeasures s2
- , imeasures = imeasures s1 ++ imeasures s2
- , classes = classes s1 ++ classes s2
- , claws = claws s1 ++ claws s2
- , termexprs = termexprs s1 ++ termexprs s2
- , rinstance = rinstance s1 ++ rinstance s2
- , ilaws = ilaws s1 ++ ilaws s2
- , dvariance = dvariance s1 ++ dvariance s2
- , axeqs = axeqs s1 ++ axeqs s2
- , embeds = mappend (embeds s1) (embeds s2)
- , lvars = S.union (lvars s1) (lvars s2)
- , lazy = S.union (lazy s1) (lazy s2)
- , rewrites = S.union (rewrites s1) (rewrites s2)
- , rewriteWith = M.union (rewriteWith s1) (rewriteWith s2)
- , fails = S.union (fails s1) (fails s2)
- , reflects = S.union (reflects s1) (reflects s2)
- , hmeas = S.union (hmeas s1) (hmeas s2)
- , hbounds = S.union (hbounds s1) (hbounds s2)
- , inlines = S.union (inlines s1) (inlines s2)
- , ignores = S.union (ignores s1) (ignores s2)
- , autosize = S.union (autosize s1) (autosize s2)
- , bounds = M.union (bounds s1) (bounds s2)
- , defs = M.union (defs s1) (defs s2)
- , autois = M.union (autois s1) (autois s2)
- }
-
-instance Monoid (Spec ty bndr) where
- mappend = (<>)
- mempty
- = Spec { measures = []
- , impSigs = []
- , expSigs = []
- , asmSigs = []
- , sigs = []
- , localSigs = []
- , reflSigs = []
- , invariants = []
- , ialiases = []
- , imports = []
- , dataDecls = []
- , newtyDecls = []
- , includes = []
- , aliases = []
- , ealiases = []
- , embeds = mempty
- , qualifiers = []
- , decr = []
- , lvars = S.empty
- , lazy = S.empty
- , rewrites = S.empty
- , rewriteWith = M.empty
- , fails = S.empty
- , autois = M.empty
- , hmeas = S.empty
- , reflects = S.empty
- , hbounds = S.empty
- , inlines = S.empty
- , ignores = S.empty
- , autosize = S.empty
- , pragmas = []
- , cmeasures = []
- , imeasures = []
- , classes = []
- , claws = []
- , termexprs = []
- , rinstance = []
- , ilaws = []
- , dvariance = []
- , axeqs = []
- , bounds = M.empty
- , defs = M.empty
- }
-
--- $liftedSpec
-
--- | A 'LiftedSpec' is derived from an input 'BareSpec' and a set of its dependencies.
--- The general motivations for lifting a spec are (a) name resolution, (b) the fact that some info is
--- only relevant for checking the body of functions but does not need to be exported, e.g.
--- termination measures, or the fact that a type signature was assumed.
--- A 'LiftedSpec' is /what we serialise on disk and what the clients should will be using/.
---
--- What we /do not/ have compared to a 'BareSpec':
---
--- * The 'localSigs', as it's not necessary/visible to clients;
--- * The 'includes', as they are probably not reachable for clients anyway;
--- * The 'reflSigs', they are now just \"normal\" signatures;
--- * The 'lazy', we don't do termination checking in lifted specs;
--- * The 'reflects', the reflection has already happened at this point;
--- * The 'hmeas', we have /already/ turned these into measures at this point;
--- * The 'hbounds', ditto as 'hmeas';
--- * The 'inlines', ditto as 'hmeas';
--- * The 'ignores', ditto as 'hmeas';
--- * The 'pragmas', we can't make any use of this information for lifted specs;
--- * The 'termexprs', we don't do termination checking in lifted specs;
---
--- Apart from less fields, a 'LiftedSpec' /replaces all instances of lists with sets/, to enforce
--- duplicate detection and removal on what we serialise on disk.
-data LiftedSpec = LiftedSpec
- { liftedMeasures :: HashSet (Measure LocBareType F.LocSymbol)
- -- ^ User-defined properties for ADTs
- , liftedImpSigs :: HashSet (F.Symbol, F.Sort)
- -- ^ Imported variables types
- , liftedExpSigs :: HashSet (F.Symbol, F.Sort)
- -- ^ Exported variables types
- , liftedAsmSigs :: HashSet (F.LocSymbol, LocBareType)
- -- ^ Assumed (unchecked) types; including reflected signatures
- , liftedSigs :: HashSet (F.LocSymbol, LocBareType)
- -- ^ Imported functions and types
- , liftedInvariants :: HashSet (Maybe F.LocSymbol, LocBareType)
- -- ^ Data type invariants; the Maybe is the generating measure
- , liftedIaliases :: HashSet (LocBareType, LocBareType)
- -- ^ Data type invariants to be checked
- , liftedImports :: HashSet F.Symbol
- -- ^ Loaded spec module names
- , liftedDataDecls :: HashSet DataDecl
- -- ^ Predicated data definitions
- , liftedNewtyDecls :: HashSet DataDecl
- -- ^ Predicated new type definitions
- , liftedAliases :: HashSet (F.Located (RTAlias F.Symbol BareType))
- -- ^ RefType aliases
- , liftedEaliases :: HashSet (F.Located (RTAlias F.Symbol F.Expr))
- -- ^ Expression aliases
- , liftedEmbeds :: F.TCEmb F.LocSymbol
- -- ^ GHC-Tycon-to-fixpoint Tycon map
- , liftedQualifiers :: HashSet F.Qualifier
- -- ^ Qualifiers in source/spec files
- , liftedDecr :: HashSet (F.LocSymbol, [Int])
- -- ^ Information on decreasing arguments
- , liftedLvars :: HashSet F.LocSymbol
- -- ^ Variables that should be checked in the environment they are used
- , liftedAutois :: M.HashMap F.LocSymbol (Maybe Int)
- -- ^ Automatically instantiate axioms in these Functions with maybe specified fuel
- , liftedAutosize :: HashSet F.LocSymbol
- -- ^ Type Constructors that get automatically sizing info
- , liftedCmeasures :: HashSet (Measure LocBareType ())
- -- ^ Measures attached to a type-class
- , liftedImeasures :: HashSet (Measure LocBareType F.LocSymbol)
- -- ^ Mappings from (measure,type) -> measure
- , liftedClasses :: HashSet (RClass LocBareType)
- -- ^ Refined Type-Classes
- , liftedClaws :: HashSet (RClass LocBareType)
- -- ^ Refined Type-Classe Laws
- , liftedRinstance :: HashSet (RInstance LocBareType)
- , liftedIlaws :: HashSet (RILaws LocBareType)
- , liftedDvariance :: HashSet (F.LocSymbol, [Variance])
- -- ^ ? Where do these come from ?!
- , liftedBounds :: RRBEnv LocBareType
- , liftedDefs :: M.HashMap F.LocSymbol F.Symbol
- -- ^ Temporary (?) hack to deal with dictionaries in specifications
- -- see tests/pos/NatClass.hs
- , liftedAxeqs :: HashSet F.Equation
- -- ^ Equalities used for Proof-By-Evaluation
- } deriving (Eq, Generic, Show)
- deriving Hashable via Generically LiftedSpec
- deriving Binary via Generically LiftedSpec
-
-
--- $trackingDeps
-
--- | A newtype wrapper around a 'Module' which:
---
--- * Allows a 'Module' to be serialised (i.e. it has a 'Binary' instance)
--- * It tries to use stable comparison and equality under the hood.
---
-newtype StableModule =
- StableModule { unStableModule :: Module }
- deriving Generic
-
--- | Converts a 'Module' into a 'StableModule'.
-toStableModule :: Module -> StableModule
-toStableModule = StableModule
-
-renderModule :: Module -> String
-renderModule m = "Module { unitId = " <> show (moduleUnitId m)
- <> ", name = " <> show (moduleName m)
- <> " }"
-
-instance Hashable StableModule where
- hashWithSalt s (StableModule mdl) = hashWithSalt s (moduleStableString mdl)
-
-instance Ord StableModule where
- (StableModule m1) `compare` (StableModule m2) = stableModuleCmp m1 m2
-
-instance Eq StableModule where
- (StableModule m1) == (StableModule m2) = (m1 `stableModuleCmp` m2) == EQ
-
-instance Show StableModule where
- show (StableModule mdl) = "Stable" ++ renderModule mdl
-
-instance Binary StableModule where
-
- put (StableModule mdl) = do
- put (unitIdString . moduleUnitId $ mdl)
- put (moduleNameString . moduleName $ mdl)
-
- get = do
- uidStr <- get
- mnStr <- get
- pure $ StableModule (Module (stringToUnitId uidStr) (mkModuleName mnStr))
-
--- | The /target/ dependencies that concur to the creation of a 'TargetSpec' and a 'LiftedSpec'.
-newtype TargetDependencies =
- TargetDependencies { getDependencies :: HashMap StableModule LiftedSpec }
- deriving (Eq, Show, Semigroup, Monoid, Generic)
- deriving Binary via Generically TargetDependencies
-
--- | Drop the given 'StableModule' from the dependencies.
-dropDependency :: StableModule -> TargetDependencies -> TargetDependencies
-dropDependency sm (TargetDependencies deps) = TargetDependencies (M.delete sm deps)
-
--- $predicates
-
--- | Returns 'True' if the input 'Var' is a /PLE/ one.
-isPLEVar :: TargetSpec -> Var -> Bool
-isPLEVar sp x = M.member x (gsAutoInst (gsRefl sp))
-
--- | Returns 'True' if the input 'Var' was exported in the module the input 'TargetSrc' represents.
-isExportedVar :: TargetSrc -> Var -> Bool
-isExportedVar src v = mkStableName n `S.member` ns
- where
- n = getName v
- ns = gsExports src
-
---
--- $legacyDataStructures
---
-{-
-data GhcInfo = GI
- { _giSrc :: !GhcSrc
- , _giSpec :: !GhcSpec -- ^ All specification information for module
- }
--}
-
-data GhcSrc = Src
- { _giIncDir :: !FilePath -- ^ Path for LH include/prelude directory
- , _giTarget :: !FilePath -- ^ Source file for module
- , _giTargetMod :: !ModName -- ^ Name for module
- , _giCbs :: ![CoreBind] -- ^ Source Code
- , _gsTcs :: ![TyCon] -- ^ All used Type constructors
- , _gsCls :: !(Maybe [ClsInst]) -- ^ Class instances?
- , _giDerVars :: !(S.HashSet Var) -- ^ Binders created by GHC eg dictionaries
- , _giImpVars :: ![Var] -- ^ Binders that are _read_ in module (but not defined?)
- , _giDefVars :: ![Var] -- ^ (Top-level) binders that are _defined_ in module
- , _giUseVars :: ![Var] -- ^ Binders that are _read_ in module
- , _gsExports :: !(HashSet StableName) -- ^ `Name`s exported by the module being verified
- , _gsFiTcs :: ![TyCon] -- ^ Family instance TyCons
- , _gsFiDcs :: ![(F.Symbol, DataCon)] -- ^ Family instance DataCons
- , _gsPrimTcs :: ![TyCon] -- ^ Primitive GHC TyCons (from TysPrim.primTyCons)
- , _gsQualImps :: !QImports -- ^ Map of qualified imports
- , _gsAllImps :: !(S.HashSet F.Symbol) -- ^ Set of _all_ imported modules
- , _gsTyThings :: ![TyThing] -- ^ All the @TyThing@s known to GHC
- }
-
-data GhcSpec = SP
- { _gsSig :: !GhcSpecSig
- , _gsQual :: !GhcSpecQual
- , _gsData :: !GhcSpecData
- , _gsName :: !GhcSpecNames
- , _gsVars :: !GhcSpecVars
- , _gsTerm :: !GhcSpecTerm
- , _gsRefl :: !GhcSpecRefl
- , _gsLaws :: !GhcSpecLaws
- , _gsImps :: ![(F.Symbol, F.Sort)] -- ^ Imported Environment
- , _gsConfig :: !Config
- , _gsLSpec :: !(Spec LocBareType F.LocSymbol) -- ^ Lifted specification for the target module
- }
-
-instance HasConfig GhcSpec where
- getConfig = _gsConfig
-
-{-
-instance HasConfig GhcInfo where
- getConfig = getConfig . _giSpec
--}
-
-{- $provisionalBackCompat
-
-In order to smooth out the migration process to this API, here we provide some /compat/ 'Iso' and 'Prism'
-to convert from/to the old data structures, so that migration can be done organically over time.
--}
-
-targetSrcIso :: Iso' GhcSrc TargetSrc
-targetSrcIso = iso toTargetSrc fromTargetSrc
- where
- toTargetSrc a = TargetSrc
- { giIncDir = _giIncDir a
- , giTarget = _giTarget a
- , giTargetMod = _giTargetMod a
- , giCbs = _giCbs a
- , gsTcs = _gsTcs a
- , gsCls = _gsCls a
- , giDerVars = _giDerVars a
- , giImpVars = _giImpVars a
- , giDefVars = _giDefVars a
- , giUseVars = _giUseVars a
- , gsExports = _gsExports a
- , gsFiTcs = _gsFiTcs a
- , gsFiDcs = _gsFiDcs a
- , gsPrimTcs = _gsPrimTcs a
- , gsQualImps = _gsQualImps a
- , gsAllImps = _gsAllImps a
- , gsTyThings = _gsTyThings a
- }
-
- fromTargetSrc a = Src
- { _giIncDir = giIncDir a
- , _giTarget = giTarget a
- , _giTargetMod = giTargetMod a
- , _giCbs = giCbs a
- , _gsTcs = gsTcs a
- , _gsCls = gsCls a
- , _giDerVars = giDerVars a
- , _giImpVars = giImpVars a
- , _giDefVars = giDefVars a
- , _giUseVars = giUseVars a
- , _gsExports = gsExports a
- , _gsFiTcs = gsFiTcs a
- , _gsFiDcs = gsFiDcs a
- , _gsPrimTcs = gsPrimTcs a
- , _gsQualImps = gsQualImps a
- , _gsAllImps = gsAllImps a
- , _gsTyThings = gsTyThings a
- }
-
-targetSpecGetter :: Getter GhcSpec (TargetSpec, LiftedSpec)
-targetSpecGetter =
- to (\ghcSpec -> (toTargetSpec ghcSpec, view (to _gsLSpec % liftedSpecGetter) ghcSpec))
- where
- toTargetSpec a = TargetSpec
- { gsSig = _gsSig a
- , gsQual = _gsQual a
- , gsData = _gsData a
- , gsName = _gsName a
- , gsVars = _gsVars a
- , gsTerm = _gsTerm a
- , gsRefl = _gsRefl a
- , gsLaws = _gsLaws a
- , gsImps = _gsImps a
- , gsConfig = _gsConfig a
- }
-
-bareSpecIso :: Iso' (Spec LocBareType F.LocSymbol) BareSpec
-bareSpecIso = iso MkBareSpec getBareSpec
-
-liftedSpecGetter :: Getter (Spec LocBareType F.LocSymbol) LiftedSpec
-liftedSpecGetter = to toLiftedSpec
- where
- toLiftedSpec a = LiftedSpec
- { liftedMeasures = S.fromList . measures $ a
- , liftedImpSigs = S.fromList . impSigs $ a
- , liftedExpSigs = S.fromList . expSigs $ a
- , liftedAsmSigs = S.fromList . asmSigs $ a
- , liftedSigs = S.fromList . sigs $ a
- , liftedInvariants = S.fromList . invariants $ a
- , liftedIaliases = S.fromList . ialiases $ a
- , liftedImports = S.fromList . imports $ a
- , liftedDataDecls = S.fromList . dataDecls $ a
- , liftedNewtyDecls = S.fromList . newtyDecls $ a
- , liftedAliases = S.fromList . aliases $ a
- , liftedEaliases = S.fromList . ealiases $ a
- , liftedEmbeds = embeds a
- , liftedQualifiers = S.fromList . qualifiers $ a
- , liftedDecr = S.fromList . decr $ a
- , liftedLvars = lvars a
- , liftedAutois = autois a
- , liftedAutosize = autosize a
- , liftedCmeasures = S.fromList . cmeasures $ a
- , liftedImeasures = S.fromList . imeasures $ a
- , liftedClasses = S.fromList . classes $ a
- , liftedClaws = S.fromList . claws $ a
- , liftedRinstance = S.fromList . rinstance $ a
- , liftedIlaws = S.fromList . ilaws $ a
- , liftedDvariance = S.fromList . dvariance $ a
- , liftedBounds = bounds a
- , liftedDefs = defs a
- , liftedAxeqs = S.fromList . axeqs $ a
- }
-
--- This is a temporary internal function that we use to convert the input dependencies into a format
--- suitable for 'makeGhcSpec'.
-unsafeFromLiftedSpec :: LiftedSpec -> Spec LocBareType F.LocSymbol
-unsafeFromLiftedSpec a = Spec
- { measures = S.toList . liftedMeasures $ a
- , impSigs = S.toList . liftedImpSigs $ a
- , expSigs = S.toList . liftedExpSigs $ a
- , asmSigs = S.toList . liftedAsmSigs $ a
- , sigs = S.toList . liftedSigs $ a
- , localSigs = mempty
- , reflSigs = mempty
- , invariants = S.toList . liftedInvariants $ a
- , ialiases = S.toList . liftedIaliases $ a
- , imports = S.toList . liftedImports $ a
- , dataDecls = S.toList . liftedDataDecls $ a
- , newtyDecls = S.toList . liftedNewtyDecls $ a
- , includes = mempty
- , aliases = S.toList . liftedAliases $ a
- , ealiases = S.toList . liftedEaliases $ a
- , embeds = liftedEmbeds a
- , qualifiers = S.toList . liftedQualifiers $ a
- , decr = S.toList . liftedDecr $ a
- , lvars = liftedLvars a
- , lazy = mempty
- , fails = mempty
- , rewrites = mempty
- , rewriteWith = mempty
- , reflects = mempty
- , autois = liftedAutois a
- , hmeas = mempty
- , hbounds = mempty
- , inlines = mempty
- , ignores = mempty
- , autosize = liftedAutosize a
- , pragmas = mempty
- , cmeasures = S.toList . liftedCmeasures $ a
- , imeasures = S.toList . liftedImeasures $ a
- , classes = S.toList . liftedClasses $ a
- , claws = S.toList . liftedClaws $ a
- , termexprs = mempty
- , rinstance = S.toList . liftedRinstance $ a
- , ilaws = S.toList . liftedIlaws $ a
- , dvariance = S.toList . liftedDvariance $ a
- , bounds = liftedBounds a
- , defs = liftedDefs a
- , axeqs = S.toList . liftedAxeqs $ a
- }
diff --git a/src/Language/Haskell/Liquid/Types/Types.hs b/src/Language/Haskell/Liquid/Types/Types.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Types/Types.hs
+++ /dev/null
@@ -1,2447 +0,0 @@
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DerivingVia #-}
-
--- | This module should contain all the global type definitions and basic instances.
-
-module Language.Haskell.Liquid.Types.Types (
-
- -- * Options
- module Language.Haskell.Liquid.UX.Config
-
- -- * Ghc Information
- , TargetVars (..)
- , TyConMap (..)
-
- -- * F.Located Things
- , F.Located (..)
- , F.dummyLoc
-
- -- * Symbols
- , F.LocSymbol
- , F.LocText
-
- -- * Default unknown name
- , F.dummyName
- , F.isDummy
-
- -- * Bare Type Constructors and Variables
- , BTyCon(..)
- , mkBTyCon
- -- , mkClassBTyCon, mkPromotedBTyCon
- , isClassBTyCon
- , BTyVar(..)
-
- -- * Refined Type Constructors
- , RTyCon (RTyCon, rtc_tc, rtc_info)
- , TyConInfo(..), defaultTyConInfo
- , rTyConPVs
- , rTyConPropVs
- -- , isClassRTyCon
- , isClassType, isEqType, isRVar, isBool
-
- -- * Refinement Types
- , RType (..), Ref(..), RTProp, rPropP
- , RTyVar (..)
- , RTAlias (..)
- , OkRT
- , lmapEAlias
- , dropImplicits
-
- -- * Worlds
- , HSeg (..)
- , World (..)
-
- -- * Classes describing operations on `RTypes`
- , TyConable (..)
- , SubsTy (..)
-
- -- * Type Variables
- , RTVar (..), RTVInfo (..)
- , makeRTVar, mapTyVarValue
- , dropTyVarInfo, rTVarToBind
- , setRtvPol
-
- -- * Predicate Variables
- , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType
- , PVKind (..)
- , Predicate (..)
-
- -- * Refinements
- , UReft(..)
-
- -- * Parse-time entities describing refined data types
- , SizeFun (..), szFun
- , DataDecl (..)
- , DataName (..), dataNameSymbol
- , DataCtor (..)
- , DataConP (..)
- , HasDataDecl (..), hasDecl
- , DataDeclKind (..)
- , TyConP (..)
-
- -- * Pre-instantiated RType
- , RRType, RRProp
- , BRType, BRProp
- , BSort, BPVar
- , RTVU, PVU
-
- -- * Instantiated RType
- , BareType, PrType
- , SpecType, SpecProp, SpecRTVar
- , SpecRep
- , LocBareType, LocSpecType
- , RSort
- , UsedPVar, RPVar, RReft
- , REnv
- , AREnv (..)
-
- -- * Constructing & Destructing RTypes
- , RTypeRep(..), fromRTypeRep, toRTypeRep
- , mkArrow, bkArrowDeep, bkArrow, safeBkArrow
- , mkUnivs, bkUniv, bkClass, bkUnivClass
- , rImpF, rFun, rCls, rRCls
-
- -- * Manipulating `Predicates`
- , pvars, pappSym, pApp
-
- -- * Some tests on RTypes
- , isBase
- , isFunTy
- , isTrivial
- , hasHole
-
- -- * Traversing `RType`
- , efoldReft, foldReft, foldReft'
- , emapReft, mapReft, mapReftM, mapPropM
- , mapExprReft
- , mapBot, mapBind
- , foldRType
-
-
- -- * ???
- , Oblig(..)
- , ignoreOblig
- , addInvCond
-
- -- * Inferred Annotations
- , AnnInfo (..)
- , Annot (..)
-
- -- * Hole Information
- , HoleInfo(..)
-
- -- * Overall Output
- , Output (..)
-
- -- * Refinement Hole
- , hole, isHole, hasHoleTy
-
- -- * Converting To and From Sort
- , ofRSort, toRSort
- , rTypeValueVar
- , rTypeReft
- , stripRTypeBase
- , topRTypeBase
-
- -- * Class for values that can be pretty printed
- , F.PPrint (..)
- , F.pprint
- , F.showpp
-
- -- * Printer Configuration
- , PPEnv (..)
- , ppEnv
- , ppEnvShort
-
- -- * Modules and Imports
- , ModName (..), ModType (..)
- , isSrcImport, isSpecImport, isTarget
- , getModName, getModString, qualifyModName
-
- -- * Refinement Type Aliases
- , RTEnv (..), BareRTEnv, SpecRTEnv, BareRTAlias, SpecRTAlias
- -- , mapRT, mapRE
-
- -- * Diagnostics, Warnings, Errors and Error Messages
- , module Language.Haskell.Liquid.Types.Errors
- , Error
- , ErrorResult
- , Warning
- , mkWarning
- , Diagnostics
- , mkDiagnostics
- , emptyDiagnostics
- , noErrors
- , allWarnings
- , allErrors
- , printWarning
-
- -- * Source information (associated with constraints)
- , Cinfo (..)
-
- -- * Measures
- , Measure (..)
- , UnSortedExprs, UnSortedExpr
- , MeasureKind (..)
- , CMeasure (..)
- , Def (..)
- , Body (..)
- , MSpec (..)
-
- -- * Scoping Info
- , BScope
-
- -- * Type Classes
- , RClass (..)
-
- -- * KV Profiling
- , KVKind (..) -- types of kvars
- , KVProf -- profile table
- , emptyKVProf -- empty profile
- , updKVProf -- extend profile
-
- -- * Misc
- , mapRTAVars
- , insertsSEnv
-
- -- * CoreToLogic
- , LogicMap(..), toLogicMap, eAppWithMap, LMap(..)
-
- -- * Refined Instances
- , RDEnv, DEnv(..), RInstance(..), RISig(..), RILaws(..)
- , MethodType(..), getMethodType
-
- -- * Ureftable Instances
- , UReftable(..)
-
- -- * String Literals
- , liquidBegin, liquidEnd
-
- , Axiom(..), HAxiom
-
- -- , rtyVarUniqueSymbol, tyVarUniqueSymbol
- , rtyVarType, tyVarVar
- )
- where
-
-import Language.Haskell.Liquid.GHC.API hiding (Expr, Target, isFunTy, LM)
-import Data.String
-import GHC.Generics
-import PrelInfo (isNumericClass)
-import Prelude hiding (error)
-import qualified Prelude
-import TyCon
-
-import Control.Monad (liftM, liftM2, liftM3, liftM4)
-import Control.DeepSeq
-import Data.Bifunctor
-import Data.Typeable (Typeable)
-import Data.Generics (Data)
-import qualified Data.Binary as B
-import qualified Data.Foldable as F
-import Data.Hashable
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-import qualified Data.List as L
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Function (on)
-import Data.List as L (foldl', nub, null)
-import Data.Text (Text)
-import Text.PrettyPrint.HughesPJ hiding (first, (<>))
-import Text.Printf
-import Language.Fixpoint.Misc
-
-import qualified Language.Fixpoint.Types as F
-
-import Language.Haskell.Liquid.Types.Generics
-import Language.Haskell.Liquid.GHC.Misc
-import Language.Haskell.Liquid.GHC.Logging as GHC
-import Language.Haskell.Liquid.Types.Variance
-import Language.Haskell.Liquid.Types.Errors
-import Language.Haskell.Liquid.Misc
-import Language.Haskell.Liquid.UX.Config
-import Data.Default
-
-
------------------------------------------------------------------------------
--- | Information about scope Binders Scope in
------------------------------------------------------------------------------
-{- In types with base refinement, e.g., {out:T {inner:a | ri} | ro }
-If BScope = True , then the outer binder out is in scope on ri
-If BScope = False, then the outer binder out is not in scope on ri
--}
-
-type BScope = Bool
------------------------------------------------------------------------------
--- | Information about Type Constructors
------------------------------------------------------------------------------
-data TyConMap = TyConMap
- { tcmTyRTy :: M.HashMap TyCon RTyCon -- ^ Map from GHC TyCon to RTyCon
- , tcmFIRTy :: M.HashMap (TyCon, [F.Sort]) RTyCon -- ^ Map from GHC Family-Instances to RTyCon
- , tcmFtcArity :: M.HashMap TyCon Int -- ^ Arity of each Family-Tycon
- }
-
-
------------------------------------------------------------------------------
--- | Printer ----------------------------------------------------------------
------------------------------------------------------------------------------
-
-data PPEnv = PP
- { ppPs :: Bool -- ^ print abstract-predicates
- , ppTyVar :: Bool -- ^ print the unique suffix for each tyvar
- , ppShort :: Bool -- ^ print the tycons without qualification
- , ppDebug :: Bool -- ^ gross with full info
- }
- deriving (Show)
-
-ppEnv :: PPEnv
-ppEnv = ppEnvDef
- { ppPs = True }
- { ppDebug = True } -- RJ: needed for resolution, because pp is used for serialization?
-
-{- | [NOTE:ppEnv] For some mysterious reason, `ppDebug` must equal `True`
- or various tests fail e.g. tests/classes/pos/TypeEquality0{0,1}.hs
- Yikes. Find out why!
- -}
-
-ppEnvDef :: PPEnv
-ppEnvDef = PP False False False False
-
-ppEnvShort :: PPEnv -> PPEnv
-ppEnvShort pp = pp { ppShort = True }
-
-------------------------------------------------------------------
--- Huh?
-------------------------------------------------------------------
-type Expr = F.Expr
-type Symbol = F.Symbol
-
-
--- [NOTE:LIFTED-VAR-SYMBOLS]: Following NOTE:REFLECT-IMPORTS, by default
--- each (lifted) `Var` is mapped to its `Symbol` via the `Symbolic Var`
--- instance. For _generated_ vars, we may want a custom name e.g. see
--- tests/pos/NatClass.hs
--- and we maintain that map in `lmVarSyms` with the `Just s` case.
--- Ideally, this bandaid should be replaced so we don't have these
--- hacky corner cases.
-
-data LogicMap = LM
- { lmSymDefs :: M.HashMap Symbol LMap -- ^ Map from symbols to equations they define
- , lmVarSyms :: M.HashMap Var (Maybe Symbol) -- ^ Map from (lifted) Vars to `Symbol`; see:
- -- NOTE:LIFTED-VAR-SYMBOLS and NOTE:REFLECT-IMPORTs
- } deriving (Show)
-
-instance Monoid LogicMap where
- mempty = LM M.empty M.empty
- mappend = (<>)
-
-instance Semigroup LogicMap where
- LM x1 x2 <> LM y1 y2 = LM (M.union x1 y1) (M.union x2 y2)
-
-data LMap = LMap
- { lmVar :: F.LocSymbol
- , lmArgs :: [Symbol]
- , lmExpr :: Expr
- }
-
-instance Show LMap where
- show (LMap x xs e) = show x ++ " " ++ show xs ++ "\t |-> \t" ++ show e
-
-toLogicMap :: [(F.LocSymbol, [Symbol], Expr)] -> LogicMap
-toLogicMap ls = mempty {lmSymDefs = M.fromList $ map toLMap ls}
- where
- toLMap (x, ys, e) = (F.val x, LMap {lmVar = x, lmArgs = ys, lmExpr = e})
-
-eAppWithMap :: LogicMap -> F.Located Symbol -> [Expr] -> Expr -> Expr
-eAppWithMap lmap f es def
- | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)
- , length xs == length es
- = F.subst (F.mkSubst $ zip xs es) e
- | Just (LMap _ xs e) <- M.lookup (F.val f) (lmSymDefs lmap)
- , isApp e
- = F.subst (F.mkSubst $ zip xs es) $ dropApp e (length xs - length es)
- | otherwise
- = def
-
-dropApp :: Expr -> Int -> Expr
-dropApp e i | i <= 0 = e
-dropApp (F.EApp e _) i = dropApp e (i-1)
-dropApp _ _ = errorstar "impossible"
-
-isApp :: Expr -> Bool
-isApp (F.EApp (F.EVar _) (F.EVar _)) = True
-isApp (F.EApp e (F.EVar _)) = isApp e
-isApp _ = False
-
-data TyConP = TyConP
- { tcpLoc :: !F.SourcePos
- , tcpCon :: !TyCon
- , tcpFreeTyVarsTy :: ![RTyVar]
- , tcpFreePredTy :: ![PVar RSort]
- , tcpVarianceTs :: !VarianceInfo
- , tcpVariancePs :: !VarianceInfo
- , tcpSizeFun :: !(Maybe SizeFun)
- } deriving (Generic, Data, Typeable)
-
-instance F.Loc TyConP where
- srcSpan tc = F.SS (tcpLoc tc) (tcpLoc tc)
-
-
--- TODO: just use Located instead of dc_loc, dc_locE
-data DataConP = DataConP
- { dcpLoc :: !F.SourcePos
- , dcpCon :: !DataCon -- ^ Corresponding GHC DataCon
- , dcpFreeTyVars :: ![RTyVar] -- ^ Type parameters
- , dcpFreePred :: ![PVar RSort] -- ^ Abstract Refinement parameters
- , dcpTyConstrs :: ![SpecType] -- ^ ? Class constraints (via `dataConStupidTheta`)
- , dcpTyArgs :: ![(Symbol, SpecType)] -- ^ Value parameters
- , dcpTyRes :: !SpecType -- ^ Result type
- -- , tyData :: !SpecType -- ^ The 'generic' ADT, see [NOTE:DataCon-Data]
- , dcpIsGadt :: !Bool -- ^ Was this specified in GADT style (if so, DONT use function names as fields)
- , dcpModule :: !F.Symbol -- ^ Which module was this defined in
- , dcpLocE :: !F.SourcePos
- } deriving (Generic, Data, Typeable)
-
--- | [NOTE:DataCon-Data] for each 'DataConP' we also
--- store the type of the constructed data. This is
--- *the same as* 'tyRes' for *vanilla* ADTs
--- (e.g. List, Maybe etc.) but may differ for GADTs.
--- For example,
---
--- data Thing a where
--- X :: Thing Int
--- Y :: Thing Bool
---
--- Here the 'DataConP' associated with 'X' (resp. 'Y')
--- has 'tyRes' corresponding to 'Thing Int' (resp. 'Thing Bool'),
--- but in both cases, the 'tyData' should be 'Thing a'.
---
-
-instance F.Loc DataConP where
- srcSpan d = F.SS (dcpLoc d) (dcpLocE d)
-
--- | Which Top-Level Binders Should be Verified
-data TargetVars = AllVars | Only ![Var]
-
-
---------------------------------------------------------------------
--- | Abstract Predicate Variables ----------------------------------
---------------------------------------------------------------------
-
-data PVar t = PV
- { pname :: !Symbol
- , ptype :: !(PVKind t)
- , parg :: !Symbol
- , pargs :: ![(t, Symbol, Expr)]
- } deriving (Generic, Data, Typeable, Show, Functor)
-
-instance Eq (PVar t) where
- pv == pv' = pname pv == pname pv' {- UNIFY: What about: && eqArgs pv pv' -}
-
-instance Ord (PVar t) where
- compare (PV n _ _ _) (PV n' _ _ _) = compare n n'
-
-instance B.Binary t => B.Binary (PVar t)
-instance NFData t => NFData (PVar t)
-
-instance Hashable (PVar a) where
- hashWithSalt i (PV n _ _ _) = hashWithSalt i n
-
-pvType :: PVar t -> t
-pvType p = case ptype p of
- PVProp t -> t
- PVHProp -> panic Nothing "pvType on HProp-PVar"
-
-data PVKind t
- = PVProp t
- | PVHProp
- deriving (Generic, Data, Typeable, Functor, F.Foldable, Traversable, Show)
-
-instance B.Binary a => B.Binary (PVKind a)
-instance NFData a => NFData (PVKind a)
-
-
---------------------------------------------------------------------------------
--- | Predicates ----------------------------------------------------------------
---------------------------------------------------------------------------------
-
-type UsedPVar = PVar ()
-
-newtype Predicate = Pr [UsedPVar]
- deriving (Generic, Data, Typeable)
- deriving Hashable via Generically Predicate
-
-instance Eq Predicate where
- (Pr vs) == (Pr ws)
- = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws']
- where
- vs' = L.sort vs
- ws' = L.sort ws
-
-
-
-instance B.Binary Predicate
-
-instance NFData Predicate where
- rnf _ = ()
-
-instance Monoid Predicate where
- mempty = pdTrue
- mappend = (<>)
-
-instance Semigroup Predicate where
- p <> p' = pdAnd [p, p']
-
-instance Semigroup a => Semigroup (UReft a) where
- MkUReft x y <> MkUReft x' y' = MkUReft (x <> x') (y <> y')
-
-instance (Monoid a) => Monoid (UReft a) where
- mempty = MkUReft mempty mempty
- mappend = (<>)
-
-
-pdTrue :: Predicate
-pdTrue = Pr []
-
-pdAnd :: Foldable t => t Predicate -> Predicate
-pdAnd ps = Pr (nub $ concatMap pvars ps)
-
-pvars :: Predicate -> [UsedPVar]
-pvars (Pr pvs) = pvs
-
-instance F.Subable UsedPVar where
- syms pv = [ y | (_, x, F.EVar y) <- pargs pv, x /= y ]
- subst s pv = pv { pargs = mapThd3 (F.subst s) <$> pargs pv }
- substf f pv = pv { pargs = mapThd3 (F.substf f) <$> pargs pv }
- substa f pv = pv { pargs = mapThd3 (F.substa f) <$> pargs pv }
-
-
-instance F.Subable Predicate where
- syms (Pr pvs) = concatMap F.syms pvs
- subst s (Pr pvs) = Pr (F.subst s <$> pvs)
- substf f (Pr pvs) = Pr (F.substf f <$> pvs)
- substa f (Pr pvs) = Pr (F.substa f <$> pvs)
-
-instance NFData r => NFData (UReft r)
-
-
-newtype BTyVar = BTV Symbol deriving (Show, Generic, Data, Typeable)
-
-newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable)
-
-instance Eq BTyVar where
- (BTV x) == (BTV y) = x == y
-
-instance Ord BTyVar where
- compare (BTV x) (BTV y) = compare x y
-
-instance IsString BTyVar where
- fromString = BTV . fromString
-
-instance B.Binary BTyVar
-instance Hashable BTyVar
-instance NFData BTyVar
-instance NFData RTyVar
-
-instance F.Symbolic BTyVar where
- symbol (BTV tv) = tv
-
-instance F.Symbolic RTyVar where
- symbol (RTV tv) = F.symbol tv -- tyVarUniqueSymbol tv
-
--- instance F.Symbolic RTyVar where
- -- symbol (RTV tv) = F.symbol . getName $ tv
--- rtyVarUniqueSymbol :: RTyVar -> Symbol
--- rtyVarUniqueSymbol (RTV tv) = tyVarUniqueSymbol tv
--- tyVarUniqueSymbol :: TyVar -> Symbol
--- tyVarUniqueSymbol tv = F.symbol $ show (getName tv) ++ "_" ++ show (varUnique tv)
-
-data BTyCon = BTyCon
- { btc_tc :: !F.LocSymbol -- ^ TyCon name with location information
- , btc_class :: !Bool -- ^ Is this a class type constructor?
- , btc_prom :: !Bool -- ^ Is Promoted Data Con?
- }
- deriving (Generic, Data, Typeable)
- deriving Hashable via Generically BTyCon
-
-instance B.Binary BTyCon
-
-data RTyCon = RTyCon
- { rtc_tc :: TyCon -- ^ GHC Type Constructor
- , rtc_pvars :: ![RPVar] -- ^ Predicate Parameters
- , rtc_info :: !TyConInfo -- ^ TyConInfo
- }
- deriving (Generic, Data, Typeable)
-
-instance F.Symbolic RTyCon where
- symbol = F.symbol . rtc_tc
-
-instance F.Symbolic BTyCon where
- symbol = F.val . btc_tc
-
-instance NFData BTyCon
-
-instance NFData RTyCon
-
-rtyVarType :: RTyVar -> Type
-rtyVarType (RTV v) = TyVarTy v
-
-tyVarVar :: RTVar RTyVar c -> Var
-tyVarVar (RTVar (RTV v) _) = v
-
-
-
-mkBTyCon :: F.LocSymbol -> BTyCon
-mkBTyCon x = BTyCon x False False
-
-
--- | Accessors for @RTyCon@
-
-isBool :: RType RTyCon t t1 -> Bool
-isBool (RApp (RTyCon{rtc_tc = c}) _ _ _) = c == boolTyCon
-isBool _ = False
-
-isRVar :: RType c tv r -> Bool
-isRVar (RVar _ _) = True
-isRVar _ = False
-
-isClassBTyCon :: BTyCon -> Bool
-isClassBTyCon = btc_class
-
--- isClassRTyCon :: RTyCon -> Bool
--- isClassRTyCon x = (isClassTyCon $ rtc_tc x) || (rtc_tc x == eqPrimTyCon)
-
-rTyConPVs :: RTyCon -> [RPVar]
-rTyConPVs = rtc_pvars
-
-rTyConPropVs :: RTyCon -> [PVar RSort]
-rTyConPropVs = filter isPropPV . rtc_pvars
-
-isPropPV :: PVar t -> Bool
-isPropPV = isProp . ptype
-
-isEqType :: TyConable c => RType c t t1 -> Bool
-isEqType (RApp c _ _ _) = isEqual c
-isEqType _ = False
-
-
-isClassType :: TyConable c => RType c t t1 -> Bool
-isClassType (RApp c _ _ _) = isClass c
-isClassType _ = False
-
--- rTyConPVHPs = filter isHPropPV . rtc_pvars
--- isHPropPV = not . isPropPV
-
-isProp :: PVKind t -> Bool
-isProp (PVProp _) = True
-isProp _ = False
-
-
-defaultTyConInfo :: TyConInfo
-defaultTyConInfo = TyConInfo [] [] Nothing
-
-instance Default TyConInfo where
- def = defaultTyConInfo
-
-
------------------------------------------------------------------------
--- | Co- and Contra-variance for TyCon --------------------------------
------------------------------------------------------------------------
-
--- | Indexes start from 0 and type or predicate arguments can be both
--- covariant and contravaariant e.g., for the below Foo dataType
---
--- data Foo a b c d Prop, q :: Int -> Prop, r :: a -> Prop>
--- = F (a ) | Q (c -> a) | G (Int Bool, q :: a -> Bool, r :: a -> Bool>."
- , " {x::a |- a <: a ) -> OList (a Bool, q :: a -> Bool, r :: a -> Bool> .\n (Ord a) =>\n {x :: {VV : a | true} |- {VV : a | true} <: {VV : a | true}) -> lq_tmp$db##15:(OList {VV : a Bool, q :: Int -> Bool>. "
- , " {Int }"
- , " {x::Int -> ()) -> x:Int Bool, q :: Int -> Bool> .\n {|- (Int <{VV : _ | true}>)} =>\n {x :: (Int <{VV : _ | true}>) -> ()) -> x:(Int <{VV : _ Bool, q :: a -> Bool>. "
- , " {{v:a | v == 0} <: a |- {v:a | x <= v} <: a | 0 <= v}] -> {v:a Bool, q :: a -> Bool> .\n {|- {v : a | v == 0} <: {VV : a | true} |- {v : a | x <= v} <: {VV : a | 0 <= v}] -> {v : a Bool, r :: a -> a -> Bool >.\n e:a ->\n e2:a -> y:a | (v = y)}) ->\n IO (RGRef Bool, r :: a a -> Bool> .\n e:{VV : a | true} -> e2:{VV : a | true} -> y:{VV : a | v == y}) -> (IO (RGRef <{VV : _ | true}, {VV : _ Bool> where"
- , " Nil2 :: List2 a "
- , " | Cons2 :: listHead:a -> listTail:List a -> List2 a b"])
- @?==
- "data List2 [a, b] = \
- \ | Cons2 :: forall a b . listHead : a ->listTail : (List a) -> (List2 a b) \
- \ | Nil2 :: forall a b . -> (List2 a)"
-
- , testCase "type spec 28" $
- parseSingleSpec (unlines $
- [ "data Ev :: Peano -> Prop where"
- , " EZ :: Prop (Ev Z)"
- , "| ESS :: n:Peano -> Prop (Ev n) -> Prop (Ev (S (S n)))"
- ])
- @?==
- "data Ev [] =\n | ESS :: forall . n : Peano ->lq_tmp$db##4 : (Prop (Ev n)) -> (Prop (Ev (S (S n))))\n | EZ :: forall . -> (Prop (Ev Z))"
-
- , testCase "type spec 29" $
- parseSingleSpec (unlines $
- [ "measure fst :: (a,b) -> a"
- , "fst (a,b) = a"
- ])
- @?==
- "measure fst :: lq_tmp$db##0:(a, b) -> a\n fst ((,)a b) = a"
- ]
-
--- ---------------------------------------------------------------------
-
-testFails :: TestTree
-testFails =
- testGroup "Does fail"
- [ testCase "Maybe k:Int -> Int" $
- parseSingleSpec "x :: Maybe k:Int -> Int" @?==
- "Cannot parse specification:\n unexpected ':'\n expecting monoPredicateP, bareTyArgP, mmonoPredicateP, white space, \"->\", \"~>\", \"=>\", \"/\" or end of input"
- ]
-
-
--- ---------------------------------------------------------------------
-
-testErrorReporting :: TestTree
-testErrorReporting =
- testGroup "Error reporting"
- [ testCase "assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n " $
- parseSingleSpec "assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n " @?==
- "Cannot parse specification:\n unexpected end of input\n expecting bareTyArgP"
-
- , testCase "Missing |" $
- parseSingleSpec "ff :: {v:Nat v >= 0 }" @?==
- -- parseSingleSpec "ff :: {v : }" @?==
- "Cannot parse specification:\n unexpected \":\"\n expecting operator, white space or \"}\""
- ]
-
--- ---------------------------------------------------------------------
-
--- | Parse a single type signature containing LH refinements. To be
--- used in the REPL.
-parseSingleSpec :: String -> String
-parseSingleSpec src = deSpace $
- case LH.singleSpecP (initialPos " Bool> where
- Nil2 :: List2 a
- | Cons2 :: listHead:a -> listTail:List a -> List2 a b
-@-}
-
-
-data List a where
- Nil :: List a
- Cons :: a -> List a -> List a
-
-
-data List1 a b where
- Nil1 :: List1 a b
- Cons1 :: a -> List a -> List1 a b
-
-data List2 a b where
- Nil2 :: List2 a b
- Cons2 :: a -> List a -> List2 a b
-
-test :: List a -> Int
-test Nil = 1
-test (Cons x xs) = 1 + test xs
-
-main :: IO ()
-main = pure ()
diff --git a/tests/errors/BadPragma0.hs b/tests/errors/BadPragma0.hs
deleted file mode 100644
--- a/tests/errors/BadPragma0.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-@ LIQUID "--idirs=.." @-}
-
-module Bad where
-
-i :: Int
-i = 1
-
diff --git a/tests/errors/BadPragma1.hs b/tests/errors/BadPragma1.hs
deleted file mode 100644
--- a/tests/errors/BadPragma1.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-@ LIQUID "--c-files=./wow.c" @-}
-
-module Bad where
-
-i :: Int
-i = 1
-
diff --git a/tests/errors/BadPragma2.hs b/tests/errors/BadPragma2.hs
deleted file mode 100644
--- a/tests/errors/BadPragma2.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-@ LIQUID "--ghc-option=-O0" @-}
-
-module Bad where
-
-i :: Int
-i = 1
-
diff --git a/tests/errors/BadPredApp.hs b/tests/errors/BadPredApp.hs
deleted file mode 100644
--- a/tests/errors/BadPredApp.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Boo where
-
-{-@ data X Int -> Int -> Int -> Bool> = C { x :: Int, y :: Int, z :: X } @-}
-data T = C { x :: Int, y :: Int, z :: X }
diff --git a/tests/errors/BadQualifier.hs b/tests/errors/BadQualifier.hs
deleted file mode 100644
--- a/tests/errors/BadQualifier.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module RG where
-data RGRef a
-{-@ measure tv :: RGRef a -> a @-}
-{-@ qualif TERMINALVALUE(r:RGRef a): (tv r) @-}
-
-
-data A
-data B
-
-{-@ qualif Foo(x:A, y:B): (x == y) @-}
diff --git a/tests/errors/BadSig0.hs b/tests/errors/BadSig0.hs
deleted file mode 100644
--- a/tests/errors/BadSig0.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Zoo where
-
-{-@ measure prop :: a -> b @-}
-{-@ type Prop E = {v:_ | pro v = E} @-}
-
-foo :: Int -> Int
-{-@ foo :: n:Int -> Prop 10 @-}
-foo x = x + 1
diff --git a/tests/errors/BadSig1.hs b/tests/errors/BadSig1.hs
deleted file mode 100644
--- a/tests/errors/BadSig1.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-{-@ LIQUID "--exact-data-con" @-}
-
-module Ev where
-
-data Peano where
- Z :: Peano
- S :: Peano -> Peano
-
--- AUTO
-data EvProp where
- Ev :: Peano -> EvProp
-
-data Ev where
- EZ :: Ev
- ESS :: Peano -> Ev -> Ev
-
--- AUTO/PRELUDE
-{-@ measure prop :: a -> b @-}
-
-{-@ type Prop E = {v:_ | pro v = E} @-}
-
- -- {v:Ev | prop v = Ev Z}
-{-@ data Ev where
- EZ :: Prop (Ev Z)
- | ESS :: evn:Peano -> {evpf:Ev | prop evpf = Ev evn} -> {zing : Ev | prop zing = Ev (S (S evn)) }
- @-}
-
-{-@ test :: n:Peano -> {v:Ev | prop v = Ev (S (S n))} -> {v:Ev | prop v = Ev n} @-}
-test :: Peano -> Ev -> Ev
-test n (ESS m q) = q
-
--- G := p : {prop p = Even (S (S n)) /\ prop p = Even (S (S m))}
--- ; q : {prop q = Even m}
--- ==> n = m
--- ==> prop q = Even n
diff --git a/tests/errors/BadSyn1.hs b/tests/errors/BadSyn1.hs
deleted file mode 100644
--- a/tests/errors/BadSyn1.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Zoo where
-
-type Foo = Int
-
-{-@ type Fooz = {v:Int | 1 < v} @-}
-
-{-@ bob :: Fooz 1000 @-}
-bob = 10 :: Int
-
diff --git a/tests/errors/BadSyn2.hs b/tests/errors/BadSyn2.hs
deleted file mode 100644
--- a/tests/errors/BadSyn2.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Zoo where
-
-type Foo = Int
-
-{-@ bob :: Foo 1000 @-}
-bob = 10 :: Int
-
diff --git a/tests/errors/BadSyn3.hs b/tests/errors/BadSyn3.hs
deleted file mode 100644
--- a/tests/errors/BadSyn3.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Zoo where
-
-type Foo = Int
-
-{-@ bob :: Foo String @-}
-bob = 10 :: Int
-
diff --git a/tests/errors/BadSyn4.hs b/tests/errors/BadSyn4.hs
deleted file mode 100644
--- a/tests/errors/BadSyn4.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Foo where
-
-type List a = [a]
-type Point = List Double
-
-{-@ foo :: n:Nat -> Point n @-}
-foo :: Int -> List Double
-foo _ = []
diff --git a/tests/errors/CyclicExprAlias0.hs b/tests/errors/CyclicExprAlias0.hs
deleted file mode 100644
--- a/tests/errors/CyclicExprAlias0.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Test0 () where
-
-{-@ expression CyclicA1 Q = CyclicA1 Q @-}
-
diff --git a/tests/errors/CyclicExprAlias1.hs b/tests/errors/CyclicExprAlias1.hs
deleted file mode 100644
--- a/tests/errors/CyclicExprAlias1.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Test2 () where
-
-{-@ expression CyclicB1 Q = CyclicB2 Q @-}
-{-@ expression CyclicB2 Q = CyclicB1 Q @-}
-
diff --git a/tests/errors/CyclicExprAlias2.hs b/tests/errors/CyclicExprAlias2.hs
deleted file mode 100644
--- a/tests/errors/CyclicExprAlias2.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Test3 () where
-
-{-@ expression CyclicC1 Q = (CyclicC2 Q) && (CyclicC3 Q) @-}
-{-@ expression CyclicC2 Q = CyclicC1 Q @-}
-{-@ expression CyclicC3 Q = CyclicC1 Q @-}
-
-
diff --git a/tests/errors/CyclicExprAlias3.hs b/tests/errors/CyclicExprAlias3.hs
deleted file mode 100644
--- a/tests/errors/CyclicExprAlias3.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Test3 () where
-
-{-@ expression CyclicD1 Q = CyclicD2 Q @-}
-{-@ expression CyclicD2 Q = CyclicD3 Q @-}
-{-@ expression CyclicD3 Q = CyclicD1 Q @-}
-
diff --git a/tests/errors/CyclicPredAlias0.hs b/tests/errors/CyclicPredAlias0.hs
deleted file mode 100644
--- a/tests/errors/CyclicPredAlias0.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Test0 () where
-
-{-@ predicate CyclicA1 Q = CyclicA1 Q @-}
-
diff --git a/tests/errors/CyclicPredAlias1.hs b/tests/errors/CyclicPredAlias1.hs
deleted file mode 100644
--- a/tests/errors/CyclicPredAlias1.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Test1 () where
-
-{-@ predicate CyclicB1 Q = CyclicB2 Q @-}
-{-@ predicate CyclicB2 Q = CyclicB1 Q @-}
-
diff --git a/tests/errors/CyclicPredAlias2.hs b/tests/errors/CyclicPredAlias2.hs
deleted file mode 100644
--- a/tests/errors/CyclicPredAlias2.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Test2 () where
-
-{-@ predicate CyclicC1 Q = CyclicC2 Q && CyclicC3 Q @-}
-{-@ predicate CyclicC2 Q = CyclicC1 Q @-}
-{-@ predicate CyclicC3 Q = CyclicC1 Q @-}
-
diff --git a/tests/errors/CyclicPredAlias3.hs b/tests/errors/CyclicPredAlias3.hs
deleted file mode 100644
--- a/tests/errors/CyclicPredAlias3.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Test3 () where
-
-{-@ predicate CyclicD1 Q = CyclicD2 Q @-}
-{-@ predicate CyclicD2 Q = CyclicD3 Q @-}
-{-@ predicate CyclicD3 Q = CyclicD1 Q @-}
-
diff --git a/tests/errors/CyclicTypeAlias0.hs b/tests/errors/CyclicTypeAlias0.hs
deleted file mode 100644
--- a/tests/errors/CyclicTypeAlias0.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Test0 () where
-
-{-@ type CyclicA1 = CyclicA2 @-}
-{-@ type CyclicA2 = CyclicA1 @-}
-
diff --git a/tests/errors/CyclicTypeAlias1.hs b/tests/errors/CyclicTypeAlias1.hs
deleted file mode 100644
--- a/tests/errors/CyclicTypeAlias1.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Test1 () where
-
-{-@ type CyclicB1 = CyclicB2 @-}
-{-@ type CyclicB2 = CyclicB3 @-}
-{-@ type CyclicB3 = CyclicB1 @-}
-
diff --git a/tests/errors/CyclicTypeAlias2.hs b/tests/errors/CyclicTypeAlias2.hs
deleted file mode 100644
--- a/tests/errors/CyclicTypeAlias2.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Test2 () where
-
-{-@ type CyclicC = [CyclicC] @-}
-
diff --git a/tests/errors/CyclicTypeAlias3.hs b/tests/errors/CyclicTypeAlias3.hs
deleted file mode 100644
--- a/tests/errors/CyclicTypeAlias3.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Test3 () where
-
-{-@ type CyclicD1 = CyclicD2 @-}
-{-@ type CyclicD2 = CyclicD3 @-}
-{-@ type CyclicD3 = CyclicD2 @-}
-
diff --git a/tests/errors/DupAlias.hs b/tests/errors/DupAlias.hs
deleted file mode 100644
--- a/tests/errors/DupAlias.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Goo () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ type BoundedNat N = {v:Nat | v < N } @-}
-{-@ predicate Foo V N = V < N @-}
-
--- TODO: Test fails when this second alias is ALSO defined.
--- FIX: should WARN that there are duplicate aliases!
-
-{-@ type BoundedNat N = {v:Nat | v <= N } @-}
-{-@ predicate Foo V N = V <= N @-}
-
-
-{-@ foo :: n:Int -> m:(BoundedNat n) -> Nat @-}
-foo :: Int -> Int -> Int
-foo n m = liquidAssert (m < n) m
diff --git a/tests/errors/DupData.hs b/tests/errors/DupData.hs
deleted file mode 100644
--- a/tests/errors/DupData.hs
+++ /dev/null
@@ -1,24 +0,0 @@
--- | See https://github.com/ucsd-progsys/liquidhaskell/issues/1175
-
-module BadVec where
-
-data OVec a = ONil
- | (:>>) {oHd :: a, oTl :: OVec a}
-infixr 5 :>>
-
-{-@ data OVec a = ONil
- | (:>>) {oHd :: a,
- oTl :: OVec {v:a | v >= oHd}} @-}
-
-
-{-@ data OVec [mylen] @-}
-{-@ measure mylen @-}
-{-@ mylen :: OVec a -> Nat @-}
-mylen :: OVec a -> Int
-mylen ONil = 0
-mylen (_ :>> xs) = 1 + mylen xs
-
-{-@ badVec :: OVec Int @-}
-badVec :: OVec Int
-badVec = 1 :>> 3 :>> 2 :>> ONil
-
diff --git a/tests/errors/DupFunSigs.hs b/tests/errors/DupFunSigs.hs
deleted file mode 100644
--- a/tests/errors/DupFunSigs.hs
+++ /dev/null
@@ -1,25 +0,0 @@
--- See https://github.com/ucsd-progsys/liquidhaskell/issues/1137
-
-import Data.List
-
-{-@ type WeekDayNum = { i:Int | 0 < i && i <= 7 } @-}
-type WeekDayNum = Int -- Mon == 1, ..., Sun == 7
-
-data WeekDay = Mon | Tue | Wed | Thu | Fri | Sat | Sun
- deriving (Read, Show, Eq, Bounded)
-
-{-@ weekdays :: { wd:[WeekDay] | len wd == 7 } @-}
-weekdays :: [WeekDay]
-weekdays = [Mon, Tue, Wed, Thu, Fri, Sat, Sun]
-
-{-@ fromWeekDayNum :: WeekDayNum -> WeekDay @-}
-fromWeekDayNum :: WeekDayNum -> WeekDay
-fromWeekDayNum i = weekdays !! (i-1)
-
-{-@ fromWeekDayNum :: WeekDay -> WeekDayNum @-}
-toWeekDayNum :: WeekDay -> WeekDayNum
-toWeekDayNum wd = case wd `elemIndex` weekdays of
- Just i -> i + 1
-
-main :: IO ()
-main = pure ()
diff --git a/tests/errors/DupMeasure.hs b/tests/errors/DupMeasure.hs
deleted file mode 100644
--- a/tests/errors/DupMeasure.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module DuplicateMeasures where
-
-
-{-@ measure lenA :: [a] -> Int
- lenA [] = 0
- lenA (x:xs) = 1 + lenA xs
- @-}
-
-{-@ measure lenA :: [a] -> Int
- lenA [] = 0
- lenA (x:xs) = 1 + lenA xs
- @-}
-
-{-@ zorg :: {v:[Int] | lenA v == 3} @-}
-zorg :: [Int]
-zorg = [1,2,3]
-
diff --git a/tests/errors/ElabLocation.hs b/tests/errors/ElabLocation.hs
deleted file mode 100644
--- a/tests/errors/ElabLocation.hs
+++ /dev/null
@@ -1,13 +0,0 @@
--- | This file tests that LH correctly localizes the elaboration error
--- to the '10 / x' term (where we get a sort-error as the 'Ratio Int'
--- is compared against '0' which appears in the refinement for '/'.)
--- You can fix this by `embed Ratio * as Int`
-
-module ElabLocation where
-
-import Data.Ratio
-
-foo :: Ratio Int -> Bool
-foo x = y == y
- where
- y = 10 / x
diff --git a/tests/errors/EmptyData.hs b/tests/errors/EmptyData.hs
deleted file mode 100644
--- a/tests/errors/EmptyData.hs
+++ /dev/null
@@ -1,6 +0,0 @@
--- | see: https://github.com/ucsd-progsys/liquidhaskell/issues/1169
-
-module Bar where
-
-{-@ data A @-}
-data A = B
diff --git a/tests/errors/EmptySig.hs b/tests/errors/EmptySig.hs
deleted file mode 100644
--- a/tests/errors/EmptySig.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-
-module Blank where
-
-{-@ :: foo -> x:Int -> {v:Int | v > x} @-}
-foo :: Int -> Int
-foo x = x - 1
diff --git a/tests/errors/ErrLocation.hs b/tests/errors/ErrLocation.hs
deleted file mode 100644
--- a/tests/errors/ErrLocation.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-
-module ErrLocation where
-
-{-@ inc :: Nat -> Nat @-}
-inc :: Int -> Int
-inc x = x + 1
-
-bar :: Int -> Int
-bar x = inc (x - 1)
-
diff --git a/tests/errors/ErrLocation2.hs b/tests/errors/ErrLocation2.hs
deleted file mode 100644
--- a/tests/errors/ErrLocation2.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-
-module ErrLocation2 where
-
-{-@ inc :: Nat -> Nat @-}
-inc :: Int -> Int
-inc x = x + 1
-
-bar :: Int -> Int
-bar x
- | x > 0 = inc (x - 1)
- | otherwise = inc x
-
diff --git a/tests/errors/ExportMeasure0.hs b/tests/errors/ExportMeasure0.hs
deleted file mode 100644
--- a/tests/errors/ExportMeasure0.hs
+++ /dev/null
@@ -1,17 +0,0 @@
--- FIX: module ExportMeasure (llen) where
-
-module ExportMeasure () where
-
-{-@ data LL [llen] @-}
-data LL a = N | C a (LL a)
-
-{-@ invariant {v:LL a | (llen v) >= 0} @-}
-
-{-@ measure llen @-}
-llen :: (LL a) -> Int
-llen(N) = 0
-llen(C x xs) = 1 + (llen xs)
-
-{-@ lmap :: (a -> b) -> xs:(LL a) -> {v: LL b | llen v = llen xs } @-}
-lmap f N = N
-lmap f (C x xs) = C (f x) (lmap f xs)
diff --git a/tests/errors/ExportReflect0.hs b/tests/errors/ExportReflect0.hs
deleted file mode 100644
--- a/tests/errors/ExportReflect0.hs
+++ /dev/null
@@ -1,28 +0,0 @@
--- LH issue #1023
-
-{-@ LIQUID "--exactdc" @-}
-{-@ LIQUID "--higherorder" @-}
-
-module Bug (foo, zogbert) where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ reflect identity @-}
-identity :: a -> a
-identity x = x
-
-{-@ reflect identity2 @-}
-identity2 :: a -> a
-identity2 x = x
-
-{-@ reflect identity3 @-}
-identity3 :: a -> a
-identity3 x = x
-
-{-@ foo :: x:a -> { identity x == x } @-}
-foo :: a -> Proof
-foo x = identity x === x *** QED
-
-{-@ reflect zogbert @-}
-zogbert :: a -> a
-zogbert x = x
diff --git a/tests/errors/Fractional.hs b/tests/errors/Fractional.hs
deleted file mode 100644
--- a/tests/errors/Fractional.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Crash where
-
-{-@ f :: (Num a) => {v:a | v > 0.0} -> a @-}
-f :: (Num a) => a -> a
-f a = a + 1
-
-{-@ g :: (Num a) => {v:a | v > 0.0} -> a @-}
-g :: (Num a) => a -> a
-g = f
diff --git a/tests/errors/HigherOrderBinder.hs b/tests/errors/HigherOrderBinder.hs
deleted file mode 100644
--- a/tests/errors/HigherOrderBinder.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-{-@ foo :: a: Int -> f: (Int -> Int) -> {v : Int | v = 123 + (f a) } @-}
-foo :: Int -> (Int -> Int) -> Int
-foo a f = f a
-
-main :: IO ()
-main = pure ()
diff --git a/tests/errors/HintMismatch.hs b/tests/errors/HintMismatch.hs
deleted file mode 100644
--- a/tests/errors/HintMismatch.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-
-{-# LANGUAGE DataKinds #-}
-
-module HintMismatch where
-
-newtype Offset struct member = Offset { unOffset :: Int }
-
-type OffsetN t = Offset (t 'Nothing)
-
-foo = Nothing
-
-{-@ bar :: t 'Nothing @-}
-bar :: t 'Nothing
-bar = undefined
diff --git a/tests/errors/HoleCrash1.hs b/tests/errors/HoleCrash1.hs
deleted file mode 100644
--- a/tests/errors/HoleCrash1.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module ListDemo where
-
-data Poo a = C { t :: Poo a }
-
-{-@ type Geq N = {v:_ | N <= v} @-}
-
-{-@ data Poo a = C { t :: Poo (Geq 0) } @-}
diff --git a/tests/errors/HoleCrash2.hs b/tests/errors/HoleCrash2.hs
deleted file mode 100644
--- a/tests/errors/HoleCrash2.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module ListDemo where
-
-data Poo a = C { t :: Poo a }
-
-{-@ type Geq a N = {v:a | N <= v} @-}
-
-{-@ data Poo a = C { t :: Poo (Geq 0) } @-}
diff --git a/tests/errors/HoleCrash3.hs b/tests/errors/HoleCrash3.hs
deleted file mode 100644
--- a/tests/errors/HoleCrash3.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module ListDemo where
-
-data List a = E | (:::) { h :: a, t :: List a }
-
-infixr 9 :::
-
-{-@ countUp :: n:Int -> List Int @-}
-countUp n = n ::: countUp (n + 1)
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/errors/Inconsistent0.hs b/tests/errors/Inconsistent0.hs
deleted file mode 100644
--- a/tests/errors/Inconsistent0.hs
+++ /dev/null
@@ -1,61 +0,0 @@
--- FAILING TEST: this test SHOULD FAIL BUT DOESN'T
--- issue #519
-
-{-# LANGUAGE DeriveFunctor #-}
-module Ast where
-
-data AstIndex = IxExpr | IxType
-
-{-@ measure isExprIndex @-}
-isExprIndex :: AstIndex -> Bool
-isExprIndex IxExpr = True
-isExprIndex _ = False
-
-{-@ measure isTypeIndex @-}
-isTypeIndex :: AstIndex -> Bool
-isTypeIndex IxType = True
-isTypeIndex _ = False
-
-data AstF f = Lit Int AstIndex
- | Var String AstIndex
- | App f f
- | Paren f
-
-{-@
- data AstF f Bool>. Fix (AstF ) -> Fix (AstF ) -> Fix (AstF ) @-}
-app f x = In $ App f x
-
-{-@ id1 :: forall Bool>. Fix (AstF p) -> Fix (AstF p) @-}
-id1 :: Fix AstF -> Fix AstF
-id1 z = z
-
-{-@ wrong :: AstT @-}
-wrong = id1 astExpr
diff --git a/tests/errors/Inconsistent1.hs b/tests/errors/Inconsistent1.hs
deleted file mode 100644
--- a/tests/errors/Inconsistent1.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Boo where
-
-{-@ incr :: Int -> Bool @-}
-incr :: Int -> Int
-incr x = x + 1
diff --git a/tests/errors/Inconsistent2.hs b/tests/errors/Inconsistent2.hs
deleted file mode 100644
--- a/tests/errors/Inconsistent2.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Mismatch where
-
-{-@ foo :: Nat @-}
-foo :: Bool
-foo = True
diff --git a/tests/errors/InlineSubExp0.hs b/tests/errors/InlineSubExp0.hs
deleted file mode 100644
--- a/tests/errors/InlineSubExp0.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-
--- https://github.com/ucsd-progsys/liquidhaskell/issues/1258
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--short-names" @-}
-
-module T1258 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-data Foo = A | B
-data Bar = C | D
-data Baz = E | F
-
-{-@ reflect f @-}
-f :: Foo -> Bar -> Baz
-f B C = F
-f _ _ = E
-
-{-@ prop :: {f B C == F} @-}
-prop = f B C === E *** QED
diff --git a/tests/errors/InlineSubExp1.hs b/tests/errors/InlineSubExp1.hs
deleted file mode 100644
--- a/tests/errors/InlineSubExp1.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-
--- https://github.com/ucsd-progsys/liquidhaskell/issues/1258
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--short-names" @-}
-
-module T1258 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-data Foo = A | B
-data Bar = C | D
-data Baz = E | F | G
-
-{-@ reflect f @-}
-f :: Foo -> Bar -> Baz
-f B C = F
-f A D = E
-f _ _ = G
-
-{-@ reflect g @-}
-g :: Foo -> Bar
-g A = C
-g _ = D
-
-test = f B (g A) === f A D *** QED
diff --git a/tests/errors/LiftMeasureCase.hs b/tests/errors/LiftMeasureCase.hs
deleted file mode 100644
--- a/tests/errors/LiftMeasureCase.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module Measures where
-
-llen :: [a] -> Int
-llen [] = 0
-llen (x:xs) = 1 + llen xs
-
-{-@ measure foo @-}
-foo :: a -> a
-foo x = x
-
-{-@ measure lllen @-}
-
-{-@ lllen :: xs:[a] -> {v:Int| (lllen xs) = v} @-}
-lllen :: [a] -> Int
-lllen [] = 0
-lllen (x:xs) = 1 + lllen xs
diff --git a/tests/errors/LocalHole.hs b/tests/errors/LocalHole.hs
deleted file mode 100644
--- a/tests/errors/LocalHole.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-module LocalHole where
-
-mysum xs = go 0 0
- where
- n = length xs
- {-@ go :: i:{Nat | i <= nowhere} -> _ -> _ @-}
- go i acc
- | i >= n = acc
- | otherwise = go (i+1) (acc + xs !! i)
diff --git a/tests/errors/MissingAssume.hs b/tests/errors/MissingAssume.hs
deleted file mode 100644
--- a/tests/errors/MissingAssume.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module OverWrite where
-
-import qualified Data.Set
-
-{-@ type UList a = {v:[a] | ListUnique v} @-}
-
-{-@ assume goober :: Nat -> Nat @-}
-
-{-@ assume reverse :: xs:(UList a) -> {v: UList a | EqElts v xs} @-}
-
-{-@ predicate ListUnique LS = (Set_emp (listDup LS)) @-}
-
-{-@ predicate EqElts X Y = ((listElts X) = (listElts Y)) @-}
-
-{-@
- measure listDup :: [a] -> (Data.Set.Set a)
- listDup([]) = {v | Set_emp v }
- listDup(x:xs) = {v | v = if (Set_mem x (listElts xs)) then (Set_cup (Set_sng x) (listDup xs)) else (listDup xs) }
- @-}
-
-{-@ foo :: xs:(UList a) -> {v: UList a | EqElts v xs} @-}
-foo = reverse
diff --git a/tests/errors/MissingField1.hs b/tests/errors/MissingField1.hs
deleted file mode 100644
--- a/tests/errors/MissingField1.hs
+++ /dev/null
@@ -1,6 +0,0 @@
--- TODO-REBARE: LH _should_ (?) complain: "Unknown field `goober` in refined definition of `Foo`"
-
-data Foo = F Int
-
-{-@ data Foo = F { goober :: Int } @-}
-
diff --git a/tests/errors/MissingField2.hs b/tests/errors/MissingField2.hs
deleted file mode 100644
--- a/tests/errors/MissingField2.hs
+++ /dev/null
@@ -1,17 +0,0 @@
--- TODO-REBARE: LH _should_ (?) complain: "Unknown field `fxx` in refined definition of `F`"
-
-module Invariant where
-
-data F a = F {fx :: a, fy :: a, fzz :: a} | G {fx :: a}
-
-{-@ data F a = F { fxx :: a, fy :: a, fz :: a}
- | G { fxx :: a }
- @-}
-
-{-@ fooG :: x:a -> {v : F a | (fxx v) > x} @-}
-fooG :: a -> F a
-fooG x = G x
-
-{-@ foo :: x:a -> {v : F a | (fxx v) > x} @-}
-foo :: a -> F a
-foo x = F x x x
diff --git a/tests/errors/MissingReflect.hs b/tests/errors/MissingReflect.hs
deleted file mode 100644
--- a/tests/errors/MissingReflect.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-import Language.Haskell.Liquid.ProofCombinators
-
--- | This fails with an error as `foo` is unbound sans the `reflect` annotation.
-
-{- reflect foo -}
-
-{-@ foo :: Nat -> xs: [Nat] -> Nat -> Bool / [len xs ]@-}
-foo :: Int -> [Int] -> Int -> Bool
-foo lo [] hi = (lo<=hi)
-foo lo (x:xs) hi = (lo<=hi) && foo lo xs x
-
-{-@ empty_foo :: lo:Nat -> hi:{Nat | lo <= hi } -> {foo lo [] hi} @-}
-empty_foo :: Int -> Int -> Proof
-empty_foo lo hi = (foo lo [] hi) ==. (lo <= hi) ==.True *** QED
-
-main :: IO ()
-main = pure ()
diff --git a/tests/errors/MissingSizeFun.hs b/tests/errors/MissingSizeFun.hs
deleted file mode 100644
--- a/tests/errors/MissingSizeFun.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--nostruct" @-}
-
-module MissingSizeFun where
-
-{-@ data List [llen] a = N | C {lhead :: a, ltail :: List a} @-}
-data List a = N | C a (List a)
-
-{-@ measure llen @-}
-llen :: List a -> Bool
-llen N = True
-llen (C _ xs) = False -- 1 + llen xs
-
-
-{-@ data List2 [llen2] a = N2 | C2 {lhead2 :: a, ltail2 :: List2 a} @-}
-data List2 a = N2 | C2 a (List2 a)
diff --git a/tests/errors/MultiInstMeasures.hs b/tests/errors/MultiInstMeasures.hs
deleted file mode 100644
--- a/tests/errors/MultiInstMeasures.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-module Blank where
-
-import Data.Word
-import GHC.Ptr
-
-{-@ class measure sizeOf :: forall a . Ptr a -> Int @-}
-
-{-@
-instance measure sizeOf :: (Ptr GHC.Word.Word16) -> Int
-sizeOf (Ptr x) = 2
-@-}
-
-{-@
-instance measure sizeOf :: (Ptr GHC.Word.Word32) -> Int
-sizeOf (Ptr y) = 4
-@-}
-
-{-@
-bar :: { p : Ptr Word32 | plen p >= (sizeOf p) }
- -> ()
-@-}
-bar :: Ptr Word32 -> ()
-bar (Ptr unused) = ()
-
-{-@
-qux :: { p : Ptr Word32 | plen p >= 0 }
- -> ()
-@-}
-qux :: Ptr Word32 -> ()
-qux (Ptr addr) = let x = Ptr addr in bar x
-
diff --git a/tests/errors/MultiRecSels.hs b/tests/errors/MultiRecSels.hs
deleted file mode 100644
--- a/tests/errors/MultiRecSels.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-module RedBlack where
-
-data RBTree a = Leaf
- | Node Color a !(RBTree a) !(RBTree a)
-
-data Color = B | R
-
-{-@ ok :: { v: RBTree Int | false} @-}
-ok = Node R (2 :: Int)
- (Node B 1 Leaf Leaf)
- (Node B 3 Leaf Leaf)
-
--- LH should give an error message that the field names are duplicates.
-
-{-@ data RBTree a = Leaf
- | Node { c :: Color
- , key :: a
- , left :: RBTree ({v:a | v < key})
- , left :: RBTree ({v:a | key < v})
- }
- @-}
diff --git a/tests/errors/ParseBind.hs b/tests/errors/ParseBind.hs
deleted file mode 100644
--- a/tests/errors/ParseBind.hs
+++ /dev/null
@@ -1,7 +0,0 @@
--- We should reject the below to disallow uppercase binders
-
-module NoUpperCaseBinders where
-
-{-@ id :: Foo:Int -> Int @-}
-id :: Int -> Int
-id x = x
diff --git a/tests/errors/ParseClass.hs b/tests/errors/ParseClass.hs
deleted file mode 100644
--- a/tests/errors/ParseClass.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Crash where
-
-class Foo a where
-{-@ class Foo where
- foo :: x:a -> {v:a | v = x}
- @-}
- foo :: a -> a
-
-instance Foo Int where
- {-@ instance Foo Int where
- foo :: x:Int -> {v:Int | v = x + 1 == 9} @-}
- foo x = x + 1
-
-instance Foo Integer where
- {-@ instance Foo Integer where
- foo :: x:Integer -> {v:Integer | v = x + 1} @-}
- foo x = x + 1
diff --git a/tests/errors/ReWrite5.hs b/tests/errors/ReWrite5.hs
deleted file mode 100644
--- a/tests/errors/ReWrite5.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-module ReWrite5 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding (filter)
-
-{-@ reflect lt5 @-}
-lt5 :: Int -> Bool
-lt5 x = x < 5
-
-{-@ reflect filter @-}
-filter _ [] = []
-filter p (x:xs) = if p x then x:(filter p xs) else filter p xs
-
--- Reject inner refinements
-{-@ rw :: xs : [{ v: Int | v > 5 }] -> { filter lt5 xs = [] } @-}
-rw :: [Int] -> ()
-rw [] = ()
-rw (_:xs) = rw xs
-
-{-@ rewriteWith bad [rw] @-}
-{-@ bad :: xs : [Int] -> { filter lt5 xs = [] } @-}
-bad :: [Int] -> ()
-bad _ = ()
diff --git a/tests/errors/ReWrite6.hs b/tests/errors/ReWrite6.hs
deleted file mode 100644
--- a/tests/errors/ReWrite6.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module ReWrite6 where
-
--- Reject non equalities
-{-@ rewrite bad @-}
-{-@ bad :: {1 < 2} @-}
-bad :: ()
-bad = ()
diff --git a/tests/errors/ReWrite7.hs b/tests/errors/ReWrite7.hs
deleted file mode 100644
--- a/tests/errors/ReWrite7.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module ReWrite7 where
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-{-@ reflect f @-}
-f :: [Int] -> Bool
-f [] = True
-f (x:xs) = f xs
-
--- Reject both sides with free vars
-{-@ rewrite bad @-}
-{-@ bad :: x : [Int] -> y : [Int] -> { f x = f y } @-}
-bad :: [Int] -> [Int] -> ()
-bad [] [] = ()
-bad (x:xs) ys = bad xs ys
-bad [] (y:ys) = bad [] ys
diff --git a/tests/errors/ReWrite8.hs b/tests/errors/ReWrite8.hs
deleted file mode 100644
--- a/tests/errors/ReWrite8.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-module ReWrite8 where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ infix ++ @-}
-
-import Prelude hiding ((++), length, head)
-
-{-@ measure length @-}
-length :: [a] -> Int
-length (_:xs) = 1 + length xs
-length [] = 0
-
-{-@ reflect head @-}
-{-@ head :: {xs : [a] | length xs >= 1} -> a @-}
-head (x:_) = x
-
-{-@ rewrite singleProof @-}
-{-@ assume singleProof ::
- { xs : [a] | True }
- -> { ys : [a] | True }
- -> { xs = ys ++ [] } @-}
-singleProof :: [a] -> [a] -> ()
-singleProof _ _ = ()
-
--- Reject both sides free vars (assumed fn)
-{-@ sp ::
- { xs : [a] | True }
- -> { ys : [a] | True }
- -> { xs = ys ++ [] } @-}
-sp :: [a] -> [a] -> ()
-sp _ _ = ()
-
-
-{-@ reflect ++ @-}
-(++)::[a] -> [a] -> [a]
-[] ++ ys = ys
-(x:xs) ++ ys = x:(xs ++ys)
-
-
diff --git a/tests/errors/ShadowFieldInline.hs b/tests/errors/ShadowFieldInline.hs
deleted file mode 100644
--- a/tests/errors/ShadowFieldInline.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-@ LIQUID "--exactdc" @-}
-
-module Range where
-
--- LH should give an error message that the field selectors `pig`
--- is shadowed and should be renamed.
-
-{-@ data Zig = Zonk { pig :: Int } @-}
-data Zig = Zonk Int
-
-{-@ prop :: z:Zig -> {v:Int | v = pig z} @-}
-prop :: Zig -> Int
-prop (Zonk n) = n
-
-{-@ inline pig @-}
-pig :: Int -> Int
-pig a = a + 1
diff --git a/tests/errors/ShadowFieldReflect.hs b/tests/errors/ShadowFieldReflect.hs
deleted file mode 100644
--- a/tests/errors/ShadowFieldReflect.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-@ LIQUID "--exactdc" @-}
-
-module Range where
-
--- LH should give an error message that the field selectors `pig`
--- is shadowed and should be renamed.
-
-{-@ data Zig = Zonk { pig :: Int } @-}
-data Zig = Zonk Int
-
-{-@ prop :: z:Zig -> {v:Int | v = pig z} @-}
-prop :: Zig -> Int
-prop (Zonk n) = n
-
-{-@ reflect pig @-}
-pig :: Int -> Int
-pig a = a + 1
diff --git a/tests/errors/ShadowMeasure.hs b/tests/errors/ShadowMeasure.hs
deleted file mode 100644
--- a/tests/errors/ShadowMeasure.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-
--- ISSUE: Currently this doesn't CRASH because the two sorts for `shadow` are the
--- same, but that is a happy coincidence. We should REJECT this program as the
--- measure has the same name as another binder.
-
-module Shadow where
-
-data Poo = Poo Int
-
-{-@ measure shadow :: Poo -> Int
- shadow (Poo n) = n
- @-}
-
-{-@ test :: p:Poo -> {v:Int | v = shadow p} @-}
-test :: Poo -> Int
-test (Poo n) = n
-
-{-@ measure shadow @-}
-shadow :: [a] -> Int
-shadow [] = 0
-shadow (x:xs) = 0
diff --git a/tests/errors/ShadowMeasureVar.hs b/tests/errors/ShadowMeasureVar.hs
deleted file mode 100644
--- a/tests/errors/ShadowMeasureVar.hs
+++ /dev/null
@@ -1,17 +0,0 @@
--- REJECT this program as the measure has the same name as another binder.
-
-module Shadow where
-
-data Poo = Poo Int
-
-{-@ measure shadow :: Poo -> Int
- shadow (Poo n) = n
- @-}
-
-{-@ test :: p:Poo -> {v:Int | v = shadow p} @-}
-test :: Poo -> Int
-test (Poo n) = n
-
-shadow :: Int
-shadow = 121
-
diff --git a/tests/errors/T1140.hs b/tests/errors/T1140.hs
deleted file mode 100644
--- a/tests/errors/T1140.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-
-module Blank where
-
-data Label = Label Int
-
-type Proof = ()
-
-{-@ foo :: Label -> Label -> Label -> Proof @-}
-foo :: Label -> Label -> Label -> Proof -> Proof
-foo a b c v = ()
-
diff --git a/tests/errors/T1498.hs b/tests/errors/T1498.hs
deleted file mode 100644
--- a/tests/errors/T1498.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module T1498 where
-
-class A a where
- f :: a -> Int
-
-instance A Int where
- {-@ f :: _ -> {x : Int | 0 < x} @-}
- f n = n
-
-{-@ x :: {x : Int | 0 < x} @-}
-x :: Int
-x = f ((-1) :: Int)
diff --git a/tests/errors/T1498A.hs b/tests/errors/T1498A.hs
deleted file mode 100644
--- a/tests/errors/T1498A.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module T1498A where
-
-class A a where
- f :: a -> Int
-
-instance A Int where
-{-@ instance A Int where
- f :: _ -> {x : Int | 0 < x}
- @-}
- f n = (-1)
diff --git a/tests/errors/T773.hs b/tests/errors/T773.hs
deleted file mode 100644
--- a/tests/errors/T773.hs
+++ /dev/null
@@ -1,11 +0,0 @@
--- | Right now this gives a rather mysterious error,
--- cannot unify `int` with `(a b)` it would be nice
--- to actually point out the offending sub-expression, namely `len x`.
-
-module LiquidR where
-
-{-@ measure goober :: String -> Int @-}
-
-{-@ incr :: x:Int -> {v:Bool | goober x == 0} @-}
-incr :: Int -> Bool
-incr = undefined
diff --git a/tests/errors/T774.hs b/tests/errors/T774.hs
deleted file mode 100644
--- a/tests/errors/T774.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-
--- | Why does this NOT fail?! Clearly there is a sort error?!
-
-module LiquidR where
-
-{-@ measure goober :: String -> Int @-}
-
-{-@ incr :: x:Int -> y:Int -> {v:Bool | goober x == goober y} @-}
-incr :: Int -> Int -> Bool
-incr = undefined
diff --git a/tests/errors/TODOUnboundAbsRef.hs b/tests/errors/TODOUnboundAbsRef.hs
deleted file mode 100644
--- a/tests/errors/TODOUnboundAbsRef.hs
+++ /dev/null
@@ -1,43 +0,0 @@
--- ISSUE: In the below datatype, mickeymouse is clearly UNBOUND, and yet
--- LH happily chugs along, and just says UNSAT at the end, instead of
--- pointing out the bogus datatype definition.
-
-module ListRange () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ LIQUID "--no-termination" @-}
-
-
-{-@
-data List [llen] a x1:a -> Bool>
- = Nil
- | Cons { lHd :: a, lTl :: List (a ) }
-@-}
-
-{-@ measure llen :: (List a) -> Int
- llen(Nil) = 0
- llen(Cons x xs) = 1 + (llen xs)
- @-}
-
-{-@ invariant {v:(List a) | ((llen v) >= 0)} @-}
-
-data List a = Nil | Cons a (List a)
-
-{-
-low, high :: Int
-low = 0
-high = 10
--}
-
-range l h =
- if l <= h then Cons l (range (l+1) h) else Nil
-
-chk y =
- case y of
- Nil -> True
- Cons x1 xs -> case xs of
- Nil -> True
- Cons x2 xs2 -> liquidAssertB (x1 <= x2) && chk xs2
-
-prop3 = chk $ range 1 100
diff --git a/tests/errors/TODOVarInTypeAlias.hs b/tests/errors/TODOVarInTypeAlias.hs
deleted file mode 100644
--- a/tests/errors/TODOVarInTypeAlias.hs
+++ /dev/null
@@ -1,84 +0,0 @@
--- VS.hs
-{-@ LIQUID "--higherorder" @-}
-{-@ LIQUID "--totality" @-}
-{-@ LIQUID "--exactdc" @-}
-
-module RL1015 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ data VerifiedSemigroup a = VerifiedSemigroup { sappend :: a -> a -> a } @-}
-data VerifiedSemigroup a = VerifiedSemigroup { sappend :: a -> a -> a }
-
-infixr 6 `sappend`
-
--- ISSUE: UNBOUND VARIABLE IN TYPE ALIAS!!!! gR should be GR
-{-@ type VSappendAssoc a GR = x:a -> y:a -> z:a
- -> { v: Proof | sappend GR x (sappend GR y z) == sappend GR (sappend gR x y) z }
- @-}
-type SappendAssoc a = a -> a -> a -> Proof
-
-{-@ axiomatize sappendInv @-}
-sappendInv :: (a -> a -> a)
- -> (a -> b) -> (b -> a)
- -> b -> b -> b
-sappendInv sappendA f g x y = f (sappendA (g x) (g y))
-{-# INLINE sappendInv #-}
-
-{-@ sappendInvAssoc :: sappendA:(a -> a -> a)
- -> sappendAAssoc:(i:a -> j:a -> k:a -> { sappendA i (sappendA j k) == sappendA (sappendA i j) k })
- -> f:(a -> b)
- -> g:(b -> a)
- -> gof:(z:a -> { g (f z) == z })
- -> x:b
- -> y:b
- -> z:b
- -> { sappendInv sappendA f g x (sappendInv sappendA f g y z) == sappendInv sappendA f g (sappendInv sappendA f g x y) z }
-@-}
-sappendInvAssoc :: (a -> a -> a)
- -> (a -> a -> a -> Proof)
- -> (a -> b)
- -> (b -> a)
- -> (a -> Proof)
- -> b -> b -> b
- -> Proof
-sappendInvAssoc sappendA sappendAAssoc f g gof x y z
- = sappendInv sappendA f g x (sappendInv sappendA f g y z)
- ==. sappendInv sappendA f g x (f (sappendA (g y) (g z)))
- ==. f (sappendA (g x) (g (f (sappendA (g y) (g z)))))
- ==. f (sappendA (g x) (sappendA (g y) (g z))) ? gof (sappendA (g y) (g z))
- ==. f (sappendA (sappendA (g x) (g y)) (g z)) ? sappendAAssoc (g x) (g y) (g z)
- ==. f (sappendA (g (f (sappendA (g x) (g y)))) (g z)) ? gof (sappendA (g x) (g y))
- ==. f (sappendA (g (sappendInv sappendA f g x y)) (g z))
- ==. sappendInv sappendA f g (sappendInv sappendA f g x y) z
- *** QED
-
-{-@ reflect vsemigroupInv @-}
-{-@ vsemigroupInv :: f:(a -> b)
- -> g:(b -> a)
- -> gof:(x:a -> { g (f x) == x })
- -> VerifiedSemigroup a
- -> VerifiedSemigroup b
-@-}
-vsemigroupInv :: (a -> b) -> (b -> a) -> (a -> Proof)
- -> VerifiedSemigroup a -> VerifiedSemigroup b
-vsemigroupInv f g gof (VerifiedSemigroup sappendA)
- = VerifiedSemigroup (sappendInv sappendA f g)
-
-
-{-@ vsgiAssoc :: f:(a -> b)
- -> g:(b -> a)
- -> gof:(x:a -> { g (f x) == x })
- -> poopa:(VerifiedSemigroup a)
- -> VSappendAssoc a poopa
- -> SappendAssoc b
-
- @-}
-vsgiAssoc :: (a -> b) -> (b -> a) -> (a -> Proof) -> VerifiedSemigroup a
- -> SappendAssoc a
- -> SappendAssoc b
-vsgiAssoc f g gof (VerifiedSemigroup sappendA) sappendAAssoc
- = sappendInvAssoc sappendA sappendAAssoc f g gof
-
- -- -> VSappendAssoc a va
- -- -> VSappendAssoc b {vsemigroupInv f g gof va}
diff --git a/tests/errors/TerminationExprNum.hs b/tests/errors/TerminationExprNum.hs
deleted file mode 100644
--- a/tests/errors/TerminationExprNum.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module TerminationExpr where
-
-{-@ showSep :: _ -> xs:_ -> _ / [xs] @-} -- use xs as reducing param
-showSep :: String -> [String] -> String
-showSep sep [] = ""
-showSep sep [x] = x
-showSep sep (x:xs) = x ++ sep ++ showSep sep xs
-
diff --git a/tests/errors/TerminationExprSort.hs b/tests/errors/TerminationExprSort.hs
deleted file mode 100644
--- a/tests/errors/TerminationExprSort.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module TerminationExpr where
-
-{-@ showSep :: _ -> xs:_ -> _ / [len ys] @-} -- use xs as reducing param
-showSep :: String -> [String] -> String
-showSep sep [] = ""
-showSep sep [x] = x
-showSep sep (x:xs) = x ++ sep ++ showSep sep xs
-
diff --git a/tests/errors/TerminationExprUnb.hs b/tests/errors/TerminationExprUnb.hs
deleted file mode 100644
--- a/tests/errors/TerminationExprUnb.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module LocalTermExpr where
-
-{- assume (!!) :: xs:[a] -> {v:Nat | v < len xs} -> a @-}
-
-mysum xs = go 0 0
- where
- n = length xs
- {-@ go :: i:_ -> _ -> _ / [nn - i] @-}
- go i acc
- | i >= n = acc
- | otherwise = go (i+1) (acc + xs !! i)
diff --git a/tests/errors/UnboundAbsRef.hs b/tests/errors/UnboundAbsRef.hs
deleted file mode 100644
--- a/tests/errors/UnboundAbsRef.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-
--- ISSUE: this "crashes" without a decent source location
--- You can fix this with the signature `ide :: forall Prop>. a -> a `
--- but it would be nice to have an error message that pinpoints the location.
--- https://github.com/ucsd-progsys/liquidhaskell/issues/655
-
-module Ide where
-
-{-@ ide :: a -> a @-}
-ide x = x
diff --git a/tests/errors/UnboundCheckVar.hs b/tests/errors/UnboundCheckVar.hs
deleted file mode 100644
--- a/tests/errors/UnboundCheckVar.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-@ LIQUID "--checks=ink" @-}
-
-module UnboundCheckVar where
-
-inc :: Int -> Int
-inc x = x + 1
-
diff --git a/tests/errors/UnboundFunInSpec.hs b/tests/errors/UnboundFunInSpec.hs
deleted file mode 100644
--- a/tests/errors/UnboundFunInSpec.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Goo () where
-
-cnt :: Int -> Int
-cnt 0 = 0
-cnt i = 1 + cnt (i-1)
-
-{-@ three :: {v:Int | (cnt v) = 3} @-}
-three :: Int
-three = 15
diff --git a/tests/errors/UnboundFunInSpec1.hs b/tests/errors/UnboundFunInSpec1.hs
deleted file mode 100644
--- a/tests/errors/UnboundFunInSpec1.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Goo where
-
-{-@ foo :: xs:_ -> {v:_ | this = rubbish } @-}
-foo _ _ = 0
diff --git a/tests/errors/UnboundFunInSpec2.hs b/tests/errors/UnboundFunInSpec2.hs
deleted file mode 100644
--- a/tests/errors/UnboundFunInSpec2.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Goo where
-
-{-@ foo :: Num a => { z : (xs:t -> {v : (t -> a) | this = rubbish }) | wow = hi } @-}
-foo :: Num a => t -> t -> a
-foo _ _ = 0
diff --git a/tests/errors/UnboundVarInAssume.hs b/tests/errors/UnboundVarInAssume.hs
deleted file mode 100644
--- a/tests/errors/UnboundVarInAssume.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Assume where
-
-{-@ assume incr :: Int -> {v : Int | v == x} @-}
-incr :: Int -> Int
-incr x = x + 1
diff --git a/tests/errors/UnboundVarInLocSig.hs b/tests/errors/UnboundVarInLocSig.hs
deleted file mode 100644
--- a/tests/errors/UnboundVarInLocSig.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Local02 where
-
-{-@ foo :: x:_ -> y:_ -> {v:Int | v = x + y} @-}
-foo :: Int -> Int -> Int
-foo arg0 = bar
- where
- {-@ bar :: x:_ -> {v:Int | v = x + barg0} @-}
- bar arg1 = arg0 + arg1
diff --git a/tests/errors/UnboundVarInReflect.hs b/tests/errors/UnboundVarInReflect.hs
deleted file mode 100644
--- a/tests/errors/UnboundVarInReflect.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module UnboundVarInReflect where
-
--- see GH #1708
-
-{-@ LIQUID "--reflection" @-}
-{-@ reflect frog @-}
-frog :: () -> Bool
-frog () = undefined
diff --git a/tests/errors/UnboundVarInSpec.hs b/tests/errors/UnboundVarInSpec.hs
deleted file mode 100644
--- a/tests/errors/UnboundVarInSpec.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Fixme where
-
-
-{-@ foo :: forall s -> Bool>.
- xs:s -> s @-}
-foo :: s -> s
-foo s = s
diff --git a/tests/ffi-include/foo.c b/tests/ffi-include/foo.c
deleted file mode 100644
--- a/tests/ffi-include/foo.c
+++ /dev/null
@@ -1,4 +0,0 @@
-#include "foo.h"
-int foo(int x) {
- return x;
-}
diff --git a/tests/ffi-include/foo.h b/tests/ffi-include/foo.h
deleted file mode 100644
--- a/tests/ffi-include/foo.h
+++ /dev/null
@@ -1,1 +0,0 @@
-int foo(int);
diff --git a/tests/import/client/CliAliasGen00.hs b/tests/import/client/CliAliasGen00.hs
deleted file mode 100644
--- a/tests/import/client/CliAliasGen00.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module CliAliasGen00 where
-
-import LibAliasGen00
-
-bar = foo 10
diff --git a/tests/import/client/CliRedBlue.hs b/tests/import/client/CliRedBlue.hs
deleted file mode 100644
--- a/tests/import/client/CliRedBlue.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module CliRedBlue where
-
-import LibBlue
-import qualified LibRedBlue as RB
-
-{-@ yumyum :: _ -> Nat @-}
-yumyum = RB.foo
diff --git a/tests/import/client/Client0.hs b/tests/import/client/Client0.hs
deleted file mode 100644
--- a/tests/import/client/Client0.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Client0 where
-
- import Client1
-
- a :: Eq a => B a -> Bool
- a (B x y) = x == y
diff --git a/tests/import/client/Client1.hs b/tests/import/client/Client1.hs
deleted file mode 100644
--- a/tests/import/client/Client1.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Client1 where
-
- import Client2
-
- data B a = B {b1 :: a, b2 :: a }
- {-@ data B a = B {b1 :: a, b2 :: {v:a | cProp b1 v } } @-}
-
-
diff --git a/tests/import/client/Client2.hs b/tests/import/client/Client2.hs
deleted file mode 100644
--- a/tests/import/client/Client2.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Client2 where
-
- {-@ reflect cProp @-}
-
- cProp :: Eq a => a -> a -> Bool
- cProp x y = x == y
-
-
diff --git a/tests/import/client/ExactGADT9.hs b/tests/import/client/ExactGADT9.hs
deleted file mode 100644
--- a/tests/import/client/ExactGADT9.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--no-adt" @-}
-
-{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}
-
-module ExactGADT9 where
-
-import ExactGADT8
-
-{-@ reflect bar @-}
-bar :: RefinedFilter Blob typ -> Bool
-bar (RefinedFilter BlobXVal) = True
-bar (RefinedFilter BlobYVal) = True
diff --git a/tests/import/client/FunClashLibLibClient.hs b/tests/import/client/FunClashLibLibClient.hs
deleted file mode 100644
--- a/tests/import/client/FunClashLibLibClient.hs
+++ /dev/null
@@ -1,12 +0,0 @@
--- TEST: the "transitively" imported name `FunClashLibLib.incr` is fully qualified and so
--- SHOULD NOT get resolved to `FunClashLibLibClient.incr`; we allow this for "re-exported" names,
--- e.g. to let `Data.Vector.Vector` get resolved to `Data.Vector.Generic.Vector` ...
--- but SOMEHOW block this. [Current workaround: make sure you import-qualified `FunClashLibLib`
--- so that the name "attaches" properly. sigh.
-
-module FunClashLibLibClient where
-
-import FunClashLib
-
-incr :: Bool -> Bool
-incr = not
diff --git a/tests/import/client/LibRedBlue.hs b/tests/import/client/LibRedBlue.hs
deleted file mode 100644
--- a/tests/import/client/LibRedBlue.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module LibRedBlue where
-
-import LibRed
-import qualified LibBlue as Blue
-
-{-@ foo :: Thing -> Nat @-}
-foo :: Thing -> Int
-foo _ = 10
diff --git a/tests/import/client/LiquidArrayInit.hs b/tests/import/client/LiquidArrayInit.hs
deleted file mode 100644
--- a/tests/import/client/LiquidArrayInit.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-module LiquidArrayInit () where
-
-import Language.Haskell.Liquid.Prelude
-import LiquidArray
-
-{-@ zero ::
- i: {v: Int | v >= 0} ->
- n: Int ->
- a: (j: {v: Int | (0 <= v && v < i)} -> {v: Int | v = 0}) ->
- (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = 0}) @-}
-zero :: Int -> Int -> (Int -> Int) -> (Int -> Int)
-zero i n a = if i >= n then a
- else zero (i + 1) n (set i 0 a)
-
-{-@ tenZeroes :: i: {v: Int | (0 <= v && v < 10)} -> {v: Int | v = 0} @-}
-tenZeroes = zero 0 10 empty
-
-{-@ zeroBackwards ::
- i: Int ->
- n: {v: Int | v > i} ->
- a: (j: {v: Int | (i < v && v < n)} -> {v: Int | v = 0}) ->
- (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = 0}) @-}
-zeroBackwards :: Int -> Int -> (Int -> Int) -> (Int -> Int)
-zeroBackwards i n a = if i < 0 then a
- else zeroBackwards (i - 1) n (set i 0 a)
-
-{-@ tenZeroes' :: i: {v: Int | (0 <= v && v < 10)} -> {v: Int | v = 0} @-}
-tenZeroes' = zeroBackwards 9 10 empty
-
-{-@ zeroEveryOther ::
- i: {v: Int | (v >= 0 && v mod 2 = 0)} ->
- n: Int ->
- a: (j: {v: Int | (0 <= v && v < i && v mod 2 = 0)} -> {v: Int | v = 0}) ->
- (k: {v: Int | (0 <= v && v < n && v mod 2 = 0)} -> {v: Int | v = 0}) @-}
-zeroEveryOther :: Int -> Int -> (Int -> Int) -> (Int -> Int)
-zeroEveryOther i n a = if i >= n then a
- else zeroEveryOther (i + 2) n (set i 0 a)
-
-{-@ stridedZeroes ::
- j: {v: Int | (v mod 2 = 0 && 0 <= v && v < 10)} -> {v: Int | v = 0} @-}
-stridedZeroes = zeroEveryOther 0 10 empty
-
-{-@ initArray :: forall a x1: a -> Bool>.
- f: (z: Int -> a ) ->
- i: {v: Int | v >= 0} ->
- n: Int ->
- a: (j: {v: Int | (0 <= v && v < i)} -> a ) ->
- (k: {v: Int | (0 <= v && v < n)} -> a ) @-}
-initArray f i n a = if i >= n then a
- else initArray f (i + 1) n (set i (f i) a)
-
-{-@ zeroInitArray ::
- i: {v: Int | v >= 0} ->
- n: Int ->
- a: (j: {v: Int | (0 <= v && v < i)} -> {v: Int | v = 0}) ->
- (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = 0}) @-}
-zeroInitArray :: Int -> Int -> (Int -> Int) -> (Int -> Int)
-zeroInitArray = initArray (const 0)
-
-{-@ tenZeroes'' :: i: {v: Int | (0 <= v && v < 10)} -> {v: Int | v = 0} @-}
-tenZeroes'' = zeroInitArray 0 10 empty
-
-{-@ initid ::
- i: {v: Int | v >= 0} ->
- n: Int ->
- a: (j: {v: Int | (0 <= v && v < i)} -> {v: Int | v = j}) ->
- (k: {v: Int | (0 <= v && v < n)} -> {v: Int | v = k}) @-}
-initid :: Int -> Int -> (Int -> Int) -> (Int -> Int)
-initid = initArray id
diff --git a/tests/import/client/LiquidArrayNullTerm.hs b/tests/import/client/LiquidArrayNullTerm.hs
deleted file mode 100644
--- a/tests/import/client/LiquidArrayNullTerm.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-module LiquidArrayNullTerm () where
-
-import Language.Haskell.Liquid.Prelude
-
-import LiquidArray
-
-upperCaseString' :: Int -> Int -> (Int -> Int) -> (Int -> Int)
-upperCaseString' n i s =
- let c = get i s in
- if c == 0 then s
- else upperCaseString' n (i + 1) (set i (c + 32) s)
-
-{-@ upperCaseString ::
- n: {v: Int | v > 0} ->
- s: (j: {v : Int | (0 <= v && v < n)} ->
- {v: Int | (j = n - 1 => v = 0)}) ->
- (j: {v : Int | (0 <= v && v < n)} ->
- {v: Int | (j = n - 1 => v = 0)})
-@-}
-upperCaseString :: Int -> (Int -> Int) -> (Int -> Int)
-upperCaseString n s = upperCaseString' n 0 s
diff --git a/tests/import/client/ListClient.hs b/tests/import/client/ListClient.hs
deleted file mode 100644
--- a/tests/import/client/ListClient.hs
+++ /dev/null
@@ -1,37 +0,0 @@
--- | A "client" that uses the reflected definitions.
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ListClient where
-
-import Prelude hiding (concat, filter, foldr, map)
-import ListLib
-
-{-@ reflect incr @-}
-incr :: Int -> Int
-incr x = x + 1
-
-{-@ reflect isPos @-}
-isPos :: Int -> Bool
-isPos x = x > 0
-
-{-@ reflect ints0 @-}
-ints0 :: [Int]
-ints0 = [0, 1, 2]
-
-{-@ reflect ints1 @-}
-ints1 :: [Int]
-ints1 = [1, 2, 3]
-
-{-@ reflect ints2 @-}
-ints2 :: [Int]
-ints2 = [1, 2]
-
-{-@ mapProp :: () -> { map incr ints0 == ints1 } @-}
-mapProp () = ()
-
-{-@ filterProp :: () -> { filter isPos ints0 == ints2 } @-}
-filterProp () = ()
-
-
diff --git a/tests/import/client/NameClashClient.hs b/tests/import/client/NameClashClient.hs
deleted file mode 100644
--- a/tests/import/client/NameClashClient.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module NameClashClient where
-
-import qualified NameClashLib as Lib
-
-data Foo = FooClient Int
-
-{-@ bar :: FooAlias -> Nat @-}
-bar :: Lib.Foo -> Int
-bar _ = 20
-
-baz = Lib.foo
diff --git a/tests/import/client/RC1015.hs b/tests/import/client/RC1015.hs
deleted file mode 100644
--- a/tests/import/client/RC1015.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-@ LIQUID "--exactdc" @-}
-{-@ LIQUID "--higherorder" @-}
-
-module RC1015 where
-
-import RL1015
-
-{-@ car :: f:Foo -> { v: a | fooFirst f 0 == 10 } -> Int @-}
-car :: Foo -> a -> Int
-car f _ = 10
-
-zag = car (Foo bling 10) (bling 0)
diff --git a/tests/import/client/ReflectClient0.hs b/tests/import/client/ReflectClient0.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient0.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module ReflectClient0 where
-
-import ReflectLib0
-
-
--- the below works with GreaterThanA instead of GreaterThan,
--- as the former is defined as a "predicate" alias.
-
-{-@ incr :: x:Nat -> {v:Nat | gtThan v x} @-}
-incr :: Int -> Int
-incr x = x + 1
diff --git a/tests/import/client/ReflectClient1.hs b/tests/import/client/ReflectClient1.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient1.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module ReflectClient0 where
-
-import ReflectLib1
-
-{-@ myHead :: {v:[a] | not (isNull v) } -> a @-}
-myHead :: [a] -> a
-myHead (x:_) = x
diff --git a/tests/import/client/ReflectClient2.hs b/tests/import/client/ReflectClient2.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient2.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--higherorder" @-}
-
-module ReflectClient2 where
-
-import ReflectLib2
-
-{-@ proof :: a -> { v: Int | incr 5 == 6 } @-}
-proof _ = incr 5
diff --git a/tests/import/client/ReflectClient3.hs b/tests/import/client/ReflectClient3.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient3.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectClient3 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-import ReflectLib3
-
--- THIS IS NEEDED TO BRING THE NAMES INTO SCOPE FOR GHC ...
-forceImports = [ undefined next
- , undefined lDay
- ]
-
--- THIS WORKS
-{-@ test2 :: { next Mon == Tue } @-}
-test2 = next Mon === Tue *** QED
-
--- THIS DOES NOT WORK, but it DOES work if we remove the
--- type parameter from `List`. However it DOES work if we
--- put this back into ReflectLib3.hs
-{-@ test4 :: { lDay Nil == Mon } @-}
-test4 = lDay Nil === Mon *** QED
diff --git a/tests/import/client/ReflectClient4.hs b/tests/import/client/ReflectClient4.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient4.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectClient4 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-import ReflectLib4
-
--- THIS IS NEEDED TO BRING THE NAMES INTO SCOPE FOR GHC ...
-forceImports = [ ]
-
-{-@ test1 :: {v:List a | v = Nil} @-}
-test1 :: List a
-test1 = Nil
-
-
-{-@ test2 :: {v:Proof | llen (Cons 1 Nil) = 1} @-}
-test2 :: Proof
-test2 = llen (Cons 1 Nil)
- === 1 + llen Nil
- === 1
- *** QED
-
-{-@ test3 :: {v:Proof | llen (Cons 1 (Cons 2 Nil)) = 2} @-}
-test3 :: Proof
-test3 = llen (Cons 1 (Cons 2 Nil))
- === 1 + llen (Cons 2 Nil)
- === 1 + 1 + llen Nil
- *** QED
-
-{-@ zen :: xs:List a -> {v:Nat | v = llen xs} @-}
-zen :: List a -> Int
-zen Nil = 0
-zen (Cons h t) = 1 + zen t
-
-{-@ test5 :: { app (Cons 1 Nil) (Cons 2 (Cons 3 Nil)) = Cons 1 (Cons 2 (Cons 3 Nil)) } @-}
-test5 = app (Cons 1 Nil) (Cons 2 (Cons 3 Nil))
- === Cons 1 (app Nil (Cons 2 (Cons 3 Nil)))
- === Cons 1 (Cons 2 (Cons 3 Nil))
- *** QED
-
-{-@ thmAppLen :: xs:List a -> ys:List a -> { llen (app xs ys) == llen xs + llen ys} @-}
-thmAppLen :: List a -> List a -> Proof
-thmAppLen Nil ys
- = ()
-
-thmAppLen (Cons x xs) ys
- = thmAppLen xs ys
diff --git a/tests/import/client/ReflectClient4a.hs b/tests/import/client/ReflectClient4a.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient4a.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectClient4a where
-
-import ReflectLib4
-
-stupidity = [ undefined gapp ]
-
-{-@ test1 :: { llen Nil == 0 } @-}
-test1 = ()
-
-{-@ test2 :: { llen (Cons 2 Nil) == 1 } @-}
-test2 = ()
-
-{-@ test3 :: { llen (Cons 1 (Cons 2 Nil)) == 2 } @-}
-test3 = ()
-
-{-@ test4 :: { app Nil Nil == Nil } @-}
-test4 = ()
-
-{-@ test5 :: { gapp Nil = Nil } @-}
-test5 = ()
-
-
diff --git a/tests/import/client/ReflectClient5.hs b/tests/import/client/ReflectClient5.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient5.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectClient5 where
-
--- import Language.Haskell.Liquid.ProofCombinators
-
-import ReflectLib5
-
-{-@ test5 :: { gapp Nil = Nil } @-}
-test5 = ()
diff --git a/tests/import/client/ReflectClient6.hs b/tests/import/client/ReflectClient6.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient6.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectClient6 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-import ReflectLib6
-
-{-@ testOK :: { next Mon == Tue } @-}
-testOK = next Mon === Tue *** QED
-
-{-@ testFAIL :: { next Tue == Mon } @-}
-testFAIL = trivial
-
diff --git a/tests/import/client/ReflectClient7.hs b/tests/import/client/ReflectClient7.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient7.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectClient7 where
-
-import ReflectLib7
-
-import Language.Haskell.Liquid.ProofCombinators
-
-data U1 p = U1
-
-{-@ axiomatize fmapU1 @-}
-fmapU1 :: (p -> q) -> U1 p -> U1 q
-fmapU1 _ _ = U1
-
-{-@ fmapU1Compose :: f:(q -> r)
- -> g:(p -> q)
- -> x:U1 p
- -> { fmapU1 (compose f g) x == compose (fmapU1 f) (fmapU1 g) x }
-@-}
-fmapU1Compose :: (q -> r) -> (p -> q)
- -> U1 p -> Proof
-fmapU1Compose f g x
- = trivial
-
- -- = fmapU1 (compose f g) x
- -- ==. U1
- -- ==. fmapU1 f (fmapU1 g x)
- -- ==. compose (fmapU1 f) (fmapU1 g) x
- -- *** QED
diff --git a/tests/import/client/ReflectClient8.hs b/tests/import/client/ReflectClient8.hs
deleted file mode 100644
--- a/tests/import/client/ReflectClient8.hs
+++ /dev/null
@@ -1,36 +0,0 @@
--- By Zack Grannan at https://github.com/ucsd-progsys/liquidhaskell/pull/1646
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--extensionality" @-}
-
-module ReflectClient8 where
-
-import ReflectLib8
-
-{-@ assume extensionality :: f:(a -> b) -> g:(a -> b) -> (x:a -> {f x == g x}) -> {f == g} @-}
-extensionality :: (a -> b) -> (a -> b) -> (a -> ()) -> ()
-extensionality _ _ _ = ()
-
-{-@ refineExt' ::
- f : (a -> Int)
- -> g : (a -> Int)
- -> (x : a -> { v : () | Refines (f x) (g x)})
- -> x : a
- -> {v : () | chooseF f g x = g x}
-@-}
-refineExt' :: (a -> Int) -> (a -> Int) -> (a -> ()) -> a -> ()
-refineExt' _ _ proof x = proof x
-
-{-@ refineExt ::
- f : (a -> Int)
- -> g : (a -> Int)
- -> (x : a -> { v : () | Refines (f x) (g x)})
- -> {v : () | RefinesF f g}
-@-}
-refineExt :: (a -> Int) -> (a -> Int) -> (a -> ()) -> ()
-refineExt f g proof =
- extensionality (chooseF f g) g (refineExt' f g proof)
-
-{-@ predicate Refines M1 M2 = choose M1 M2 = M2 @-}
-{-@ predicate RefinesF F1 F2 = chooseF F1 F2 = F2 @-}
diff --git a/tests/import/client/RewriteClient.hs b/tests/import/client/RewriteClient.hs
deleted file mode 100644
--- a/tests/import/client/RewriteClient.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module RewriteClient where
-
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--max-rw-ordering-constraints=1" @-}
-
-{-@ infix ++ @-}
-
-import RewriteLib
-
-{-@ rewriteWith assoc2 [assoc] @-}
-{-@ assoc2 :: xs:[a] -> ys:[a] -> zs:[a] -> ws:[a]
- -> { xs ++ (ys ++ (zs ++ ws)) == ((xs ++ ys) ++ zs) ++ ws } @-}
-assoc2 :: [a] -> [a] -> [a] -> [a] -> ()
-assoc2 xs ys zs ws
- = () {-
- assoc xs ys (zs ++ ws)
- `const` assoc (xs ++ ys) zs ws
--}
diff --git a/tests/import/client/STClient.hs b/tests/import/client/STClient.hs
deleted file mode 100644
--- a/tests/import/client/STClient.hs
+++ /dev/null
@@ -1,45 +0,0 @@
--- TAG: classes
--- TAG: bounds
-
-{-@ LIQUID "--no-pattern-inline" @-}
-{-@ LIQUID "--higherorder" @-}
-
-module STClient where
-
-import STLib
-
---------------------------------------------------------------------------------
-
-{-@ fresh :: forall x1: a -> Bool, r :: x0: Int -> Bool>.
- i: Int ->
- a: (j: {v: Int ) ->
- (k: Int ) @-}
-set :: Int -> a -> (Int -> a) -> (Int -> a)
-set i x a = \k -> if k == i then x else a k
-
-{-@ get :: forall a x1: a -> Bool, r :: x0: Int -> Bool>.
- i: Int ) ->
- a @-}
-get :: Int -> (Int -> a) -> a
-get i a = a i
-
-{-@ empty :: i: {v: Int | 0 = 1} -> a @-}
-empty :: Int -> a
-empty = const undefined
diff --git a/tests/import/lib/ListLib.hs b/tests/import/lib/ListLib.hs
deleted file mode 100644
--- a/tests/import/lib/ListLib.hs
+++ /dev/null
@@ -1,31 +0,0 @@
--- | A module with some definitions for Lists
-{-@ LIQUID "--reflection" @-}
-
-module ListLib where
-
-import Prelude hiding (concat, filter, foldr, map)
-
-{-@ reflect map @-}
-map :: (a -> b) -> [a] -> [b]
-map f [] = []
-map f (x:xs) = f x : map f xs
-
-{-@ reflect filter @-}
-filter :: (a -> Bool) -> [a] -> [a]
-filter f [] = []
-filter f (x:xs) = if f x then x : filter f xs else filter f xs
-
-{-@ reflect append @-}
-append :: [a] -> [a] -> [a]
-append [] ys = ys
-append (x:xs) ys = x : append xs ys
-
-{-@ reflect concat @-}
-concat :: [[a]] -> [a]
-concat [] = []
-concat (l:ls) = append l (concat ls)
-
-{-@ reflect foldr @-}
-foldr :: (a -> b -> b) -> b -> [a] -> b
-foldr f i [ ] = i
-foldr f i (x:xs) = f x (foldr f i xs)
diff --git a/tests/import/lib/NameClashLib.hs b/tests/import/lib/NameClashLib.hs
deleted file mode 100644
--- a/tests/import/lib/NameClashLib.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module NameClashLib where
-
-data Foo = FooLib Int
-
-{-@ type FooAlias = {v : Foo | False} @-}
-foo :: Foo -> Int
-foo _ = 10
diff --git a/tests/import/lib/Peano.hs b/tests/import/lib/Peano.hs
deleted file mode 100644
--- a/tests/import/lib/Peano.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-{-@ LIQUID "--exact-data-con" @-}
-{-@ LIQUID "--higherorder" @-}
-{-@ LIQUID "--ple" @-}
-{-@ LIQUID "--noadt" @-}
-
-
-module Peano where
-
---------------------------------------------------------------------------------
--- | Peano Numbers -------------------------------------------------------------
---------------------------------------------------------------------------------
-
-{-@ data Peano [toNat] @-}
-data Peano where
- Z :: Peano
- S :: Peano -> Peano
-
-{-@ measure toNat @-}
-{-@ toNat :: Peano -> Nat @-}
-toNat :: Peano -> Int
-toNat Z = 0
-toNat (S n) = 1 + toNat n
-
-{-@ reflect plus @-}
-plus :: Peano -> Peano -> Peano
-plus Z n = n
-plus (S m) n = S (plus m n)
-
-{-@ reflect double @-}
-double :: Peano -> Peano
-double n = plus n n
diff --git a/tests/import/lib/RL1015.hs b/tests/import/lib/RL1015.hs
deleted file mode 100644
--- a/tests/import/lib/RL1015.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--exactdc" @-}
-{-@ LIQUID "--higherorder" @-}
-
-module RL1015 where
-
-data Foo = Foo { fooFirst :: Int -> Int , fooSnd :: Int}
-
-{-@ data Foo = Foo { fooFirst :: Int -> Int , fooSnd :: Nat } @-}
-
-{-@ bar :: f:Foo -> { v: a | fooFirst f 0 == 10 } -> Int @-}
-bar :: Foo -> a -> Int
-bar f _ = 10
-
-{-@ reflect bling @-}
-bling :: Int -> Int
-bling x = 10
-
-bag = bar (Foo bling 10) (bling 0)
diff --git a/tests/import/lib/ReflectLib0.hs b/tests/import/lib/ReflectLib0.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib0.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module ReflectLib0 where
-
-{-@ inline gtThan @-}
-gtThan :: Int -> Int -> Bool
-gtThan x y = x > y
-
-
-{-@ predicate GreaterThanA X Y = X > Y @-}
diff --git a/tests/import/lib/ReflectLib1.hs b/tests/import/lib/ReflectLib1.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib1.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module ReflectLib1 where
-
-{-@ measure isNull @-}
-isNull :: [a] -> Bool
-isNull [] = True
-isNull (x:xs) = False
diff --git a/tests/import/lib/ReflectLib2.hs b/tests/import/lib/ReflectLib2.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib2.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-@ LIQUID "--higherorder" @-}
-
-module ReflectLib2 where
-
-{-@ reflect incr @-}
-incr :: Int -> Int
-incr x = x + 1
-
-{-@ reflect incr2 @-}
-incr2 :: Int -> Int -> Int
-incr2 x y = x + y
-
-{-@ reflect plus @-}
-plus :: Int -> Int
-plus x = apply incr x
-
-{-@ reflect apply @-}
-apply :: (a -> b) -> a -> b
-apply f x = f x
-
-{-@ reflect toNat @-}
-toNat :: Int -> Int
-{-@ toNat :: Nat -> Nat @-}
-toNat n = if n == 0 then 0 else (1 + toNat (n - 1))
-
-
-{-@ myproof :: a -> { v: Int | incr 5 == 6 } @-}
-myproof _ = incr 5
diff --git a/tests/import/lib/ReflectLib3.hs b/tests/import/lib/ReflectLib3.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib3.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectLib3 where
-
-import Language.Haskell.Liquid.ProofCombinators
-
--- | Days ---------------------------------------------------------------------
-
-{-@ data Day = Mon | Tue @-}
-data Day = Mon | Tue
-
-{-@ reflect next @-}
-next :: Day -> Day
-next Mon = Tue
-next Tue = Mon
-
--- | Lists ---------------------------------------------------------------------
-
-{-@ data List a = Nil | Cons {lHd :: a} @-}
-data List a = Nil | Cons a
-
-{-@ reflect lDay @-}
-lDay :: List a -> Day
-lDay Nil = Mon
-lDay (Cons x) = Tue
diff --git a/tests/import/lib/ReflectLib4.hs b/tests/import/lib/ReflectLib4.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib4.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectLib4 where
-
--- | Lists ---------------------------------------------------------------------
-
-{-@ data List [llen] @-}
-data List a = Nil | Cons {lHd :: a, lTl :: List a}
-
-{-@ measure llen @-}
-{-@ llen :: List a -> Nat @-}
-llen :: List a -> Int
-llen Nil = 0
-llen (Cons h t) = 1 + llen t
-
--- TODO: make this work WITHOUT the invariant
-{- invariant {v:List a | 0 <= llen v} @-}
-
-{-@ reflect app @-}
-app :: List a -> List a -> List a
-app Nil ys = ys
-app (Cons x xs) ys = Cons x (app xs ys)
-
-{-@ reflect gapp @-}
-gapp :: List a -> List a
-gapp Nil = Nil
-gapp (Cons x xs) = Nil
-
-{-@ test4 :: { gapp Nil = Nil } @-}
-test4 = ()
diff --git a/tests/import/lib/ReflectLib5.hs b/tests/import/lib/ReflectLib5.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib5.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectLib5 where
-
--- | Days ---------------------------------------------------------------------
-
-{-@ data Day = Mon | Tue @-}
-data Day = Mon | Tue
-
-{-@ reflect next @-}
-next :: Day -> Day
-next Mon = Tue
-next Tue = Mon
-
-{-@ reflect lDay @-}
-lDay :: List a -> Day
-lDay Nil = Mon
-lDay (Cons x) = Tue
-
--- | Lists ---------------------------------------------------------------------
-
-data List a = Nil | Cons {lHd :: a}
-
-{-@ reflect gapp @-}
-gapp :: List a -> List a
-gapp Nil = Nil
-gapp (Cons x) = Cons x
-
-{-@ test4 :: { gapp Nil = Nil } @-}
-test4 = ()
diff --git a/tests/import/lib/ReflectLib6.hs b/tests/import/lib/ReflectLib6.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib6.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-module ReflectLib6 where
-
-data Day = Mon | Tue
-
-{-@ reflect next @-}
-next :: Day -> Day
-next Mon = Tue
-next Tue = Mon
-
-{-@ testFAIL :: { next Mon == Tue } @-}
-testFAIL = ()
diff --git a/tests/import/lib/ReflectLib7.hs b/tests/import/lib/ReflectLib7.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib7.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-@ LIQUID "--higherorder" @-}
-{-@ LIQUID "--exactdc" @-}
-
-module ReflectLib7 where
-
-{-@ reflect compose @-}
-compose :: (b -> c) -> (a -> b) -> a -> c
-compose f g x = f (g x)
diff --git a/tests/import/lib/ReflectLib8.hs b/tests/import/lib/ReflectLib8.hs
deleted file mode 100644
--- a/tests/import/lib/ReflectLib8.hs
+++ /dev/null
@@ -1,11 +0,0 @@
--- By Zack Grannan at https://github.com/ucsd-progsys/liquidhaskell/pull/1646
-
-{-@ LIQUID "--reflection" @-}
-module ReflectLib8 where
-
-{-@ reflect choose @-}
-choose _ b = b
-
-{-@ reflect chooseF @-}
-chooseF f g x =
- choose (f x) (g x)
diff --git a/tests/import/lib/RewriteLib.hs b/tests/import/lib/RewriteLib.hs
deleted file mode 100644
--- a/tests/import/lib/RewriteLib.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--ple" @-}
-
-{-@ infix ++ @-}
-
-module RewriteLib where
-import Prelude hiding ((++))
-
-{-@ reflect ++ @-}
-(++)::[a] -> [a] -> [a]
-[] ++ ys = ys
-(x:xs) ++ ys = x:(xs ++ys)
-
-{-@ assoc :: xs:[a] -> ys:[a] -> zs:[a]
- -> { xs ++ (ys ++ zs) == (xs ++ ys) ++ zs } @-}
-assoc :: [a] -> [a] -> [a] -> ()
-assoc [] _ _ = ()
-assoc (_:xs) ys zs = assoc xs ys zs
diff --git a/tests/import/lib/STLib.hs b/tests/import/lib/STLib.hs
deleted file mode 100644
--- a/tests/import/lib/STLib.hs
+++ /dev/null
@@ -1,43 +0,0 @@
--- TAG: classes
--- TAG: bounds
-
-{-@ LIQUID "--no-pattern-inline" @-}
-
-module STLib where
-
-data ST s a = S {runSt :: s -> (a, s) }
-
-{-@ data ST s a Bool, q :: a -> s -> Bool>.
- ST -> (a, s) s -> Bool>. x:a -> ST <{v:s | true}, p, {v:a | true}> s a ;
- >>= :: forall Bool>. Int -> Int @-}
-id2 :: Int -> Int
-id2 x = x
-
-{-@ type Neg = Int<{\x -> x < 0}> @-}
-
-{-@ three :: Neg @-}
-three = id2 3
diff --git a/tests/neg/AdtPeano0.hs b/tests/neg/AdtPeano0.hs
deleted file mode 100644
--- a/tests/neg/AdtPeano0.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-@ LIQUID "--exact-data-con" @-}
-{-@ LIQUID "--higherorder" @-}
-
-module Peano where
-
-data Influx = Silly Int
-
-{-@ reflect thing @-}
-thing :: Influx -> Int
-thing (Silly a) = a + 1
-
-{-@ reflect bling @-}
-bling :: Influx -> Int
-bling (Silly b) = b
-
-{-@ test :: m:Influx -> { thing m = bling m} @-}
-test :: Influx -> (Int, Int)
-test m = (thing m, bling m)
diff --git a/tests/neg/AdtPeano1.hs b/tests/neg/AdtPeano1.hs
deleted file mode 100644
--- a/tests/neg/AdtPeano1.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-@ LIQUID "--exact-data-con" @-}
-{-@ LIQUID "--higherorder" @-}
-
-module Peano where
-
-data Influx = Silly { goo :: Int }
-
-{-@ test1:: n:Int -> m:Int -> { v:() | Silly n /= Silly m } -> { n == m } @-}
-test1 :: Int -> Int -> () -> Int
-test1 n m z = moo (Silly n) + moo (Silly m)
-
-{-@ reflect moo @-}
-moo :: Influx -> Int
-moo (Silly a) = a
diff --git a/tests/neg/Ast.hs b/tests/neg/Ast.hs
deleted file mode 100644
--- a/tests/neg/Ast.hs
+++ /dev/null
@@ -1,54 +0,0 @@
--- FAILING TEST: this test SHOULD FAIL BUT DOESN'T
--- issue #519
-
-{-# LANGUAGE DeriveFunctor #-}
-module AST where
-
-data AstIndex = IxExpr | IxType
-
-{-@ measure isExprIndex @-}
-isExprIndex :: AstIndex -> Bool
-isExprIndex IxExpr = True
-isExprIndex _ = False
-
-{-@ measure isTypeIndex @-}
-isTypeIndex :: AstIndex -> Bool
-isTypeIndex IxType = True
-isTypeIndex _ = False
-
-data AstF f = Lit Int AstIndex
- | Var String AstIndex
- | App f f
- | Paren f
-
-{-@
- data AstF f Bool>. Fix (AstF ) -> Fix (AstF ) @-}
-id1 :: Fix AstF -> Fix AstF
-id1 z = z
-
-{-@ wrong :: AstT @-}
-wrong = id1 astExpr
diff --git a/tests/neg/AutoSize.hs b/tests/neg/AutoSize.hs
deleted file mode 100644
--- a/tests/neg/AutoSize.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module AutoSize where
-
-import GHC.Base
-
-data List a = N | Cons a (List a)
-
-
-nil = N
-cons = Cons
-
-foo :: List a -> Int
-foo N = 0
-foo (Cons x xs) = 1 + foo xs
-
-
-data Exp = EConst Int | EBinOp Int Exp Exp
-
-expSize :: Exp -> Int
-expSize (EConst _) = 0
-expSize e@(EBinOp _ e1 e2) = 1 + (expSize e) + (expSize e2)
diff --git a/tests/neg/AutoTerm1.hs b/tests/neg/AutoTerm1.hs
deleted file mode 100644
--- a/tests/neg/AutoTerm1.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Isort where
-
-data F = F | C Int F
-
-{-@ data F [lenF] @-}
-
-{-@ measure lenF @-}
-lenF :: F -> Int
-
-
-{-@ lenF :: xs:F -> {v:Int | v >= 1000 } @-}
-lenF F = 0
-lenF (C _ x) = 1 + lenF x
-
-
-bar :: F -> Int
-bar F = 0
-bar (C x xs) = x + bar xs
diff --git a/tests/neg/Automate.hs b/tests/neg/Automate.hs
deleted file mode 100644
--- a/tests/neg/Automate.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-@ LIQUID "--ple-local" @-}
-module Automate where
-
-import Language.Haskell.Liquid.ProofCombinators
-
-
-fibA :: Int -> Int
-{-@ axiomatize fibA @-}
-{-@ fibA :: Nat -> Nat @-}
-fibA i | i <= 1 = i
- | otherwise = fibA (i-1) + fibA (i-2)
-
-
-fibR :: Int -> Int
-{-@ reflect fibR @-}
-{-@ fibR :: Nat -> Nat @-}
-fibR i | i <= 1 = i
- | otherwise = fibR (i-1) + fibR (i-2)
-
-
-{-@ prop :: () -> {fibA 30 == 832040 } @-}
-prop :: () -> Proof
-prop _ = trivial
-
--- This is unsafe because it is actually false
-
-{-@ propUNSAFE :: () -> {fibA 30 == 832042 } @-}
-propUNSAFE :: () -> Proof
-propUNSAFE _ = trivial
-
-
--- This is unsafe because the reflected fibR (vs. axiomatized fibA)
--- does not create an SMT axiom
-{-@ propR :: () -> {fibR 30 == 832040 } @-}
-propR :: () -> Proof
-propR _ = trivial
diff --git a/tests/neg/BadNats.hs b/tests/neg/BadNats.hs
deleted file mode 100644
--- a/tests/neg/BadNats.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Nats where
-
-{-@ poo :: {v:Int | v == 0 } @-}
-poo :: Int
-poo = 1
-
-data Peano = Z | O
-
-bob :: String
-bob = "I am a cat"
-
-{-@ axiomatize one @-}
-one :: Peano
-one = O
-
-{-@ axiomatize zero @-}
-zero :: Peano
-zero = Z
diff --git a/tests/neg/Baz.hs b/tests/neg/Baz.hs
deleted file mode 100644
--- a/tests/neg/Baz.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-@ LIQUID "--short-names" @-}
-
-module Baz where
-
-{-@ incr :: x:Int -> {v:Int | v < x } @-}
-incr :: Int -> Int
-incr xana = id $ xana + 1
-
-
-{-@ iincr :: x:Int -> {v:Int | v < x } @-}
-iincr :: Int -> Int
-iincr x = x + 1
-
-
-
diff --git a/tests/neg/BigNum.hs b/tests/neg/BigNum.hs
deleted file mode 100644
--- a/tests/neg/BigNum.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module BigNum where
-
-{-@ type Foo = { v : Integer | 0 <= v && v < 4611686018427387903 * 8 } @-}
-
-{-@ f :: i : Foo -> { o : Foo | i < o } @-}
-f :: Integer -> Integer
-f i = i * 2
diff --git a/tests/neg/BinarySearchOverflow.hs b/tests/neg/BinarySearchOverflow.hs
deleted file mode 100644
--- a/tests/neg/BinarySearchOverflow.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-{-@ LIQUID "--no-termination" @-}
-
-module BinarySearch where
-
-import Prelude hiding (Num(..))
-import CheckedNum
-import Data.Vector as V
-import Language.Haskell.Liquid.Prelude (liquidAssert)
-
-{-@ invariant {v:V.Vector a | 0 <= vlen v && BoundInt (vlen v)} @-}
-
-binarySearch :: Ord a => a -> V.Vector a -> Maybe Int
-binarySearch x v
- | 0 < n = loop x v 0 (n - 1)
- | otherwise = Nothing
- where n = V.length v
-
-{-@ type Idx Vec = {v:Nat | v < vlen Vec} @-}
-
-{-@ type BoundNat = {v:Nat | BoundInt v} @-}
-
-{-@ loop :: Ord a => a -> vec:V.Vector a -> lo:Idx vec -> {hi:Idx vec | lo <= hi} -> Maybe Nat @-}
-loop :: Ord a => a -> V.Vector a -> Int -> Int -> Maybe Int
-loop x v lo hi = do
- -- let mid = lo + ((hi - lo) `div` 2) -- SAFE
- let mid = (hi + lo) `div` 2 -- UNSAFE
- if x < v ! mid
- then do
- let hi' = mid - 1
- if lo <= hi'
- then loop x v lo hi'
- else Nothing
- else if v ! mid < x
- then do
- let lo' = mid + 1 -- incr mid
- if lo' <= hi
- then loop x v lo' hi
- else Nothing
- else Just mid
-
-
-
diff --git a/tests/neg/Books.hs b/tests/neg/Books.hs
deleted file mode 100644
--- a/tests/neg/Books.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-#define DISCOUNT_PERCENTAGE 2
-#define BOOK_THRESHOLD 2
-
-module Books where
-
-calculateDiscount' :: Customer -> Int -> Int
-
----------------------------------------------------------------------------------------
--- 1. Define: Types of customers
----------------------------------------------------------------------------------------
-
-data Customer = Vip | Reg deriving (Eq)
-
----------------------------------------------------------------------------------------
--- 2. Define: Discountable Customers and Discounts
----------------------------------------------------------------------------------------
-
-{-@ inline customerGetsDiscount @-}
-customerGetsDiscount :: Customer -> Int -> Bool
-customerGetsDiscount c i = c == Vip && i >= BOOK_THRESHOLD
-
-{-@ inline discount @-}
-discount :: Int -> Int
-discount bookCount = (bookCount - BOOK_THRESHOLD) * DISCOUNT_PERCENTAGE
-
-{-@ type Discount i = {v:Int | v == discount i} @-}
-
----------------------------------------------------------------------------------------
--- 3. Policy: Only compute discounts for discountable customers
----------------------------------------------------------------------------------------
-
-{-@ calculateDiscount' :: c:Customer -> i:{Int | customerGetsDiscount c i} -> Discount i @-}
-calculateDiscount' c i = discount i
-
----------------------------------------------------------------------------------------
--- 4. Implement: Code to compute discounts, if suitable, is accepted
----------------------------------------------------------------------------------------
-
-{-@ calculateDiscount :: Int -> Nat -> Nat @-}
-calculateDiscount userId bookCount
- | getsDiscount = calculateDiscount' c bookCount
- | otherwise = 0
- where
- getsDiscount = customerGetsDiscount c bookCount
- c = customerType userId
-
----------------------------------------------------------------------------------------
--- 5. Buggy Implementation, with wrong check, is rejected
----------------------------------------------------------------------------------------
-
-{-@ misCalculateDiscount :: Int -> Nat -> Nat @-}
-misCalculateDiscount userId bookCount
- | getsDiscount = calculateDiscount' c bookCount
- | otherwise = 0
- where
- getsDiscount = c == Vip
- c = customerType userId
-
-customerType :: Int -> Customer
-customerType = undefined
diff --git a/tests/neg/CastedTotality.hs b/tests/neg/CastedTotality.hs
deleted file mode 100644
--- a/tests/neg/CastedTotality.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Fixme where
-
-import Language.Haskell.Liquid.Prelude
-
-main = show x
- where Just x = (Nothing :: Maybe Int)
-
-
-main0 = do
- let Just x = Nothing
- print (x :: Int)
-
diff --git a/tests/neg/CharLiterals.hs b/tests/neg/CharLiterals.hs
deleted file mode 100644
--- a/tests/neg/CharLiterals.hs
+++ /dev/null
@@ -1,9 +0,0 @@
--- see #1286
-
-module Example where
-
-{-@ fails :: {v:Bool | v} @-}
-fails = 'a' == 'b'
-
-{-@ ok :: {v:Bool | v} @-}
-ok = "a" == "a"
diff --git a/tests/neg/CheckedNum.hs b/tests/neg/CheckedNum.hs
deleted file mode 100644
--- a/tests/neg/CheckedNum.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module CheckedNum where
-
--- Hiding numeric operations, because they get by default translated to SMT equivalent
-import Prelude hiding (Num(..))
-
-import qualified Prelude as Prelude
-
-class CheckedNum a where
- (+) :: a -> a -> a
- (-) :: a -> a -> a
-
-{-@ predicate BoundInt X = 0 < X + 10000 && X < 10000 @-}
-
-instance CheckedNum Int where
-{-@ instance CheckedNum Int where
- - :: x:Int -> y:{v:Int | BoundInt (x - v)} -> {v: Int | v == x - y} ;
- + :: x:Int -> y:{v:Int | BoundInt (x + v)} -> {v: Int | v == x + y}
- @-}
- x - y = (Prelude.-) x y
-
- x + y = (Prelude.+) x y
-
-{-@ good :: {v:Int | v == 9999} @-}
-good :: Int
-good = 5000 + 4999
-
-{-@ bad :: {v:Int | v == 10001} @-}
-bad :: Int
-bad = 5000 + 5001
-
diff --git a/tests/neg/Class1.hs b/tests/neg/Class1.hs
deleted file mode 100644
--- a/tests/neg/Class1.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-module Class () where
-
-import Language.Haskell.Liquid.Prelude
-import Prelude hiding (sum, length, (!!), Functor(..))
-import qualified Prelude as P
-
-{-@ qualif Sz(v:int, xs:a): v = (sz xs) @-}
-
-{-@ data List a = Nil | Cons (hd::a) (tl::(List a)) @-}
-data List a = Nil | Cons a (List a)
-
-{-@ length :: xs:List a -> {v:Nat | v = (sz xs)} @-}
-length :: List a -> Int
-length Nil = 0
-length (Cons x xs) = 1 + length xs
-
-{-@ (!!) :: xs:List a -> {v:Nat | v < (sz xs)} -> a @-}
-(!!) :: List a -> Int -> a
-Nil !! i = undefined
-(Cons x _) !! 0 = x
-(Cons x xs) !! i = xs !! (i - 1)
-
-{-@ class measure sz :: forall a. a -> Int @-}
-{-@ class Sized s where
- size :: forall a. x:s a -> {v:Nat | v = (sz x)}
- @-}
-class Sized s where
- size :: s a -> Int
-
-instance Sized List where
- {-@ instance measure sz :: List a -> Int
- sz (Nil) = 0
- sz (Cons x xs) = 1 + (sz xs)
- @-}
- size = length
-
-{-@ class (Sized s) => Indexable s where
- index :: forall a. x:s a -> {v:Nat | v < (sz x)} -> a
- @-}
-class (Sized s) => Indexable s where
- index :: s a -> Int -> a
-
-
-instance Indexable List where
- index = (!!)
-
-{-@ sum :: Indexable s => s Int -> Int @-}
-sum :: Indexable s => s Int -> Int
-sum xs = go max 0
- where
- max = size xs
- go (d::Int) i
- | i < max = index xs i + go (d-1) (i+1)
- | otherwise = index xs i -- should be 0
-
-
-{-@ sumList :: List Int -> Int @-}
-sumList :: List Int -> Int
-sumList xs = go max 0
- where
- max = size xs
- go (d::Int) i
- | i < max = index xs i + go (d-1) (i+1)
- | otherwise = index xs i -- should be 0
-
-
diff --git a/tests/neg/Class2.hs b/tests/neg/Class2.hs
deleted file mode 100644
--- a/tests/neg/Class2.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-module Class () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ class measure sz :: forall a. a -> Int @-}
-
-{-@ class Sized s where
- size :: forall a. x:s a -> {v:Nat | v = sz x}
- @-}
-class Sized s where
- size :: s a -> Int
-
-instance Sized [] where
- {-@ instance measure sz :: [a] -> Int
- sz ([]) = 0
- sz (x:xs) = 1 + (sz xs)
- @-}
-
- size [] = 0
- size (x:xs) = 1 + size xs
-
--- The following is needed to make this work (but are invariants checked?)
-{- invariant {v:[a] | sz v == len v} @-}
-
-{-@ class (Sized s) => Indexable s where
- index :: forall a. x:s a -> {v:Nat | v < sz x} -> a
- @-}
-class (Sized s) => Indexable s where
- index :: s a -> Int -> a
-
-
-instance Indexable [] where
- index = (!!)
-
diff --git a/tests/neg/Class3.hs b/tests/neg/Class3.hs
deleted file mode 100644
--- a/tests/neg/Class3.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-module Class where
-
-import Language.Haskell.Liquid.Prelude
-import Prelude hiding (sum, length, (!!), Functor(..))
-import qualified Prelude as P
-
-{-@ qualif Sz(v:int, xs:a): v = (sz xs) @-}
-
-data List a = Nil | Cons a (List a)
-
-{-@ class measure sz :: forall a. a -> Int @-}
-{-@ class Sized s where
- size :: forall a. x:s a -> {v:Nat | v = 23 + sz x}
- @-}
-class Sized s where
- size :: s a -> Int
-
-instance Sized List where
- {-@ instance measure sz :: List a -> Int
- sz (Nil) = 0
- sz (Cons x xs) = 1 + (sz xs)
- @-}
- size Nil = 0
- size (Cons x xs) = size xs
diff --git a/tests/neg/Class4.hs b/tests/neg/Class4.hs
deleted file mode 100644
--- a/tests/neg/Class4.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-@ LIQUID "--no-termination" @-}
-
-module Class4 where
-
-import Language.Haskell.Liquid.Prelude
-
-class Frog a where
- mkInt :: a -> Int
- mkInt _ = liquidAssert (0 > 1) 10
-
-{-@ class Frog a where
- mkInt :: a -> Int
- @-}
-
-instance Frog Int where
-
diff --git a/tests/neg/CompareConstraints.hs b/tests/neg/CompareConstraints.hs
deleted file mode 100644
--- a/tests/neg/CompareConstraints.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-@ LIQUID "--no-totality" @-}
-
-module Foo where
-
-import Language.Haskell.Liquid.Prelude
-
-
-{-@ mycmp :: forall Bool, q :: a -> Bool>.
- {x::a , y::a ] -> [a Bool, q :: a -> Bool>.
- {x::a , y::a -> a Bool, q :: a -> Bool, r :: a -> Bool>.
- {x::a |- a <: a ) -> OList (a Bool> = Foo { x::Int }@-}
-
-data Foo a= Foo {x :: Int}
-
-{-@ foo :: Foo <{\v -> v /= 1}> Int @-}
-foo :: Foo Int
-foo = Foo 1
diff --git a/tests/neg/LazyWhere.hs b/tests/neg/LazyWhere.hs
deleted file mode 100644
--- a/tests/neg/LazyWhere.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module LazyWhere () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ pos :: Nat -> Int @-}
-pos :: Int -> Int
-pos = undefined
-
-
-{-@ lazyvar z @-}
-foo = if x > 0 then z else z
- where z = pos x
- x = choose 0
diff --git a/tests/neg/LazyWhere1.hs b/tests/neg/LazyWhere1.hs
deleted file mode 100644
--- a/tests/neg/LazyWhere1.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module LazyWhere () where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ pos :: Nat -> Int @-}
-pos :: Int -> Int
-pos = undefined
-
-{-@ safeDiv :: Int -> {v:Int| v != 0} -> Int @-}
-safeDiv :: Int -> Int -> Int
-safeDiv = undefined
-
-
--- Limitations :: Definitions of lazy variables should be alpha renamed,
--- otherwise, internal variables will be created and the expression will be
--- unsafe
-
-{-@ lazyvar z @-}
-foo = if x > 0 then z else x
- where z = (42 `safeDiv` x) + ( pos x)
- x = choose 0
diff --git a/tests/neg/LetRecStack.hs b/tests/neg/LetRecStack.hs
deleted file mode 100644
--- a/tests/neg/LetRecStack.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-{-@ LIQUID "--eliminate=all" @-}
--- | This test case is to check that LH properly accounts for the case where GHC Core
--- contains stuff like:
--- foo :: T
--- foo =
--- let t1 = e1
--- t2 = e2
--- ...
--- tn = en
--- in
--- let rec bar = e
--- in
--- bar
---
--- where `T` is a liquid type specification. This sort of stuff is introduced by GHC8
--- in order to manage the implicit `CallStack` parameters, but it ends up generating
--- extra KVars where none are needed (as we already have the signature.)
-
-{-@ LIQUID "--no-termination" @-}
-
-module Foo (prop) where
-
---data Peano a = Z a | S (Peano a) | P (Peano a)
-data Peano = Z | S (Peano ) | P (Peano)
-
-{- foo :: Peano -> Nat @-}
-foo :: Peano -> Int
-foo =
- let t0 = 0
- t1 = 1
- in
- let baz p = case p of
- Z -> t0
- S p -> t1 + baz p
- P p -> error ms
- where
- ms = "yikes"
- in
- baz
-
--- USE THIS AS THE NEG VERSION
-{-@ prop :: Peano -> Nat @-}
-prop = foo
diff --git a/tests/neg/ListConcat.hs b/tests/neg/ListConcat.hs
deleted file mode 100644
--- a/tests/neg/ListConcat.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-
-module Foo () where
-import Data.Set (Set(..))
-import Prelude hiding (concat)
-
-{-@ measure llElts :: [[a]] -> (Set a)
- llElts([]) = {v | Set_emp v }
- llElts(x:xs) = {v | v = Set_cup (listElts x) (llElts xs) }
- @-}
-
-
-{-@ concat :: ys:[[a]] -> {v:[a] | listElts v = llElts ys } @-}
-concat :: [[a]] -> [a]
-concat [] = []
-concat ([]: xs) = concat xs
-concat ((y:ys):xs) = concat (ys:xs)
-
-
-
-
-
-
diff --git a/tests/neg/ListElem.hs b/tests/neg/ListElem.hs
deleted file mode 100644
--- a/tests/neg/ListElem.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module ListElem (listElem) where
-
-import Data.Set
-
-{-@ listElem :: (Eq a)
- => y:a
- -> xs:[a]
- -> {v:Bool | v <=> Set_mem y (listElts xs)}
- @-}
-
-listElem :: (Eq a) => a -> [a] -> Bool
-listElem _ [] = False
-listElem y (x:_xs)
- | x == y = True
- | otherwise = True -- listElem y xs
diff --git a/tests/neg/ListKeys.hs b/tests/neg/ListKeys.hs
deleted file mode 100644
--- a/tests/neg/ListKeys.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-@ LIQUID "--pruneunsorted" @-}
-
-module Foo () where
-import Data.Set (Set(..))
-
-{-@ measure listKeys :: [(k, v)] -> (Set k)
- listKeys([]) = {v | Set_emp v }
- listKeys(x:xs) = {v | v = Set_cup (Set_sng (fst x)) (listKeys xs) }
- @-}
-
-
-{-@ getFsts :: ys:[(a, a)] -> {v:[a] | listElts v = listKeys ys } @-}
-getFsts ::[(a, a)] -> [a]
-getFsts [] = []
-getFsts ((_, x): xs) = x : getFsts xs
-
-
-
-
-
-
diff --git a/tests/neg/ListMSort.hs b/tests/neg/ListMSort.hs
deleted file mode 100644
--- a/tests/neg/ListMSort.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module ListSort () where
-
-import Language.Haskell.Liquid.Prelude
-
-
-split :: [a] -> ([a], [a])
-split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs
-split xs = (xs, [])
-
-merge :: Ord a => [a] -> [a] -> [a]
-merge xs [] = xs
-merge [] ys = ys
-merge (x:xs) (y:ys)
- | x <= y
- = x:(merge xs (y:ys))
- | otherwise
- = y:(merge (x:xs) ys)
-
-{-@ mergesort :: (Ord a) => xs:[a] -> [a]<{\fld v -> (v < fld)}> @-}
-mergesort :: Ord a => [a] -> [a]
-mergesort [] = []
-mergesort [x] = [x]
-mergesort xs = merge (mergesort xs1) (mergesort xs2) where (xs1, xs2) = split xs
-
-chk [] = liquidAssertB True
-chk (x1:xs) = case xs of
- [] -> liquidAssertB True
- x2:xs2 -> liquidAssertB (x1 <= x2) && chk xs
-
-rlist = map choose [1 .. 10]
-
-bar = mergesort rlist
-
-prop0 = chk bar
diff --git a/tests/neg/ListRange.hs b/tests/neg/ListRange.hs
deleted file mode 100644
--- a/tests/neg/ListRange.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module ListRange () where
-
-import Language.Haskell.Liquid.Prelude
-
-
-data List a = Nil | Cons a (List a)
-
-{-
-low, high :: Int
-low = 0
-high = 10
--}
-
-range l h =
- if l <= h then Cons l (range (l+1) h) else Nil
-
-chk y =
- case y of
- Nil -> True
- Cons x1 xs -> case xs of
- Nil -> True
- Cons x2 xs2 -> liquidAssertB (x1 == x2) && chk xs2
-
-prop3 = chk $ range 1 100
diff --git a/tests/neg/LocalSpec.hs b/tests/neg/LocalSpec.hs
deleted file mode 100644
--- a/tests/neg/LocalSpec.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Foo () where
-
-import Language.Haskell.Liquid.Prelude (choose)
-
-
-prop = if x < 0 then bar x else x
- where x = choose 0
- {-@ bar :: Nat -> Nat @-}
- bar :: Int -> Int
- bar x = x
-
-{-@ bar :: a -> {v:Int | v = 9} @-}
-bar :: a -> Int
-bar _ = 8
diff --git a/tests/neg/MaybeMonad.hs b/tests/neg/MaybeMonad.hs
deleted file mode 100644
--- a/tests/neg/MaybeMonad.hs
+++ /dev/null
@@ -1,36 +0,0 @@
--- TODO-REBARE: STRATA
-module MaybeMonad where
-
-import Prelude hiding (take)
-
-{-@ monadicStyle :: Pos -> [a] -> Maybe [a] @-}
-monadicStyle i xs =
- do checkSizeMaybe i head xs
- return (take i xs)
-
-{-@ maybeStyle :: Pos -> [a] -> Maybe [a] @-}
-maybeStyle i xs =
- case checkSizeMaybe i head xs of
- Just _ -> Just $ take i xs
- Nothing -> Nothing
-
-
-{-@ type Pos = {v:Int | 0 < v } @-}
-
-{-@
-checkSizeMaybe ::
- n:Nat
- -> (bs:{[a] | n <= len bs } -> b)
- -> bs:[a]
- -> {v:Maybe b | isJust v => n <= len bs}
-@-}
-
-checkSizeMaybe :: Int -> ([a] -> b) -> [a] -> Maybe b
-checkSizeMaybe sz f bs
- | length bs >= sz = Just (f bs)
- | otherwise = Nothing
-
-{-@ take :: i:Nat -> xs:{[a] | i <= len xs} -> [a] @-}
-take :: Int -> [a] -> [a]
-take 0 [] = []
-take i (x:xs) = if i == 0 then [] else x:(take (i-1) xs)
diff --git a/tests/neg/MeasureContains.hs b/tests/neg/MeasureContains.hs
deleted file mode 100644
--- a/tests/neg/MeasureContains.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-module Fixme where
-
-import Language.Haskell.Liquid.Prelude
-
-{-@ LIQUID "--no-termination" @-}
-
-{-@ measure containsV @-}
-{-@ measure binderContainsV @-}
-
-
-binderContainsV :: Binder n -> Bool
-binderContainsV B = True
-binderContainsV (M x) = containsV x
-
-data Binder n = B | M (TT n)
-data TT n = V Int | Other | Bind (Binder n) (TT n)
-
-containsV :: TT n -> Bool
-containsV (V i) = True
-containsV (Bind b body) = (binderContainsV b) || (containsV body)
--- containsV (App f arg) = (containsV f) || (containsV arg)
--- containsV (Proj tm i) = containsV tm
-containsV _ = False
-
-
-prop1 = liquidAssert (containsV $ Other)
diff --git a/tests/neg/MeasureDups.hs b/tests/neg/MeasureDups.hs
deleted file mode 100644
--- a/tests/neg/MeasureDups.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module Measures where
-
-import Data.Set
-
-{-@ LIQUID "--no-termination" @-}
-{-@ measure elements @-}
-{-@ measure dups @-}
-
-data F a = F a | C a (F a) | E
-
-dups :: Ord a => F a -> Set a
-dups E = empty
-dups (F a) = empty
-dups (C x xs) = if member x (elements xs) then singleton x `union` dups xs else dups xs
-
-elements :: Ord a => F a -> Set a
-elements E = empty
-elements (F a) = singleton a
-elements (C x xs) = singleton x `union` elements xs
-
-
-
-{-@ foo :: (Ord a) => x:F a -> {v:Set a | (dups x) = v} @-}
-foo :: Ord a => F a -> Set a
-foo E = empty
-foo (F a) = empty
-foo (C x xs) = if member x (elements xs) then singleton x `union` foo xs else foo xs
-
-
-
-{-@ prop :: { v: Bool | v } @-}
-prop = dups s == empty
- where
- s = C 1 (C 3 (F 1)) :: F Int
diff --git a/tests/neg/MergeSort.hs b/tests/neg/MergeSort.hs
deleted file mode 100644
--- a/tests/neg/MergeSort.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-------------------------------------------------------------------------------
--- | An implementation of Merge Sort, where LH verifies:
--- 1. Termination (Totality)
--- 2. The output is indeed in non-decreasing order
-------------------------------------------------------------------------------
-
-module MergeSort (sort) where
-
-{-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}
-
-{-@ type OListN a N = {v:OList a | len v == N} @-}
-
--- | The top level `sort` function. Proved:
--- (a) terminating,
--- (b) ordered, and
--- (c) of same size as input.
-
-{-@ sort :: (Ord a) => xs:[a] -> OListN a {len xs} @-}
-sort :: Ord a => [a] -> [a]
-sort [] = []
-sort [x] = [x]
-sort xs = merge (sort xs1) (sort xs2)
- where
- (xs1, xs2) = split xs
-
--- Fun fact: if you delete the singleton case above,
--- the resulting function is, in fact, non-terminating!
-
--- | A type describing two `Halves` of a list `Xs`
-
-{-@ type Halves a Xs = {v: (Half a Xs, Half a Xs) | len (fst v) + len (snd v) == len Xs} @-}
-
--- | Each `Half` is empty or smaller than the input:
-
-{-@ type Half a Xs = {v:[a] | 2 * len v < 1 + len Xs} @-}
-
--- | The `split` function breaks its list into two `Halves`:
-
-{-@ split :: xs:[a] -> Halves a xs @-}
-split :: [a] -> ([a], [a])
-split (x:(y:zs)) = (x:xs, y:ys) where (xs, ys) = split zs
-split xs = (xs, [])
-
--- | Finally, the `merge` function combines two ordered lists into a single ordered result.
-
-{-@ merge :: Ord a => xs:OList a -> ys:OList a -> OListN a {len xs + len ys} / [(len xs + len ys)] @-}
-merge :: Ord a => [a] -> [a] -> [a]
-merge xs [] = xs
-merge [] ys = ys
-merge (x:xs) (y:ys)
- | x <= y = x : merge xs (y:ys)
- | otherwise = y : merge (x:xs) ys
diff --git a/tests/neg/MultiParamTypeClasses.hs b/tests/neg/MultiParamTypeClasses.hs
deleted file mode 100644
--- a/tests/neg/MultiParamTypeClasses.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-class Add a b where
- rAdd :: [a] -> [b] -> [a]
-
-{-@ instance (Num k) => Add k k where
- rAdd ::
- x : {v : [k] | len v > 0}
- -> {v : [k] | (len v = len x) && len v > 0}
- -> {v : [k] | len v > 0}
-
-@-}
-instance (Num k) => Add k k where
- rAdd x y = x
-
-main = putStrLn (show (rAdd ([] :: [Double]) ([] :: [Double])))
diff --git a/tests/neg/MultipleInvariants.hs b/tests/neg/MultipleInvariants.hs
deleted file mode 100644
--- a/tests/neg/MultipleInvariants.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module Blank where
-
-import Data.Word
-import GHC.Ptr
-
-
-{-@ measure sizeOf :: forall a . Ptr a -> Int @-}
-
-{-@ invariant {v:Ptr Word16 | sizeOf v = 2} @-}
-{-@ invariant {v:Ptr Word32 | sizeOf v = 4} @-}
-
-
-{-@ bar :: p:_ -> {v:_ | sizeOf p == 4 }@-}
-bar :: Ptr Word32 -> ()
-bar (Ptr _) = ()
-
-{-@ foo :: p:_ -> {v:_ | sizeOf p == 2 }@-}
-foo :: Ptr Word16 -> ()
-foo (Ptr _) = ()
-
-
-{-@ unsound :: _ -> {v:_ | false} @-}
-unsound :: Ptr Word32 -> ()
-unsound (Ptr _) = ()
diff --git a/tests/neg/NameResolution.hs b/tests/neg/NameResolution.hs
deleted file mode 100644
--- a/tests/neg/NameResolution.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Fixme where
-
-import Prelude hiding ((==), (++))
-import Language.Haskell.Liquid.Equational
-
-
-{-@ bar :: () -> Int @-}
-bar :: () -> Int
-bar _
- = 1
- ==. 2
-
-
-{-@ (==..) :: x:a -> y:{a | x == y} -> {v:a | v == y && v == x} @-}
-(==..) :: a -> a -> a
-_ ==.. x = x
-
-{-@ foo :: () -> Int @-}
-foo :: () -> Int
-foo _
- = 1
- ==.. 2
-
-
-{-@ (++) :: a -> a -> a @-}
-(++) :: a -> a -> a
-x ++ _ = x
diff --git a/tests/neg/NoExhaustiveGuardsError.hs b/tests/neg/NoExhaustiveGuardsError.hs
deleted file mode 100644
--- a/tests/neg/NoExhaustiveGuardsError.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Foo where
-
-bar :: Int -> Int -> Int
-bar x y | x > y = 1
- | x == y = 0
diff --git a/tests/neg/NoMethodBindingError.hs b/tests/neg/NoMethodBindingError.hs
deleted file mode 100644
--- a/tests/neg/NoMethodBindingError.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Foo where
-
-class Foo a where
- foo :: a -> a
-
-instance Foo Int where
--- no method binding error
---
-goo :: Int -> Int
-goo = foo
diff --git a/tests/neg/PairMeasure.hs b/tests/neg/PairMeasure.hs
deleted file mode 100644
--- a/tests/neg/PairMeasure.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module Foo () where
-
-{-@ LIQUID "--bscope" @-}
-
-{-@ measure getfst :: (a, b) -> a
- getfst (x, y) = x
- @-}
-
-{-@ type Pair a b = {v0 : ({v:a | v = (getfst v0)}, b) | true } @-}
-
-{-@ type OPList a b = [(Pair a b)]<\h -> {v: (Pair a b) | (getfst v) >= (getfst h)}> @-}
-
-{-@ type OList a = [a]<\h -> {v: a | (v >= h)}> @-}
-
-{-@ getFsts :: OPList a b -> OList a @-}
-getFsts [] = []
-getFsts ((x,_) : xs) = x : getFsts xs
-
-{-@ canary :: a -> {v:a | false} @-}
-canary x = x
diff --git a/tests/neg/Propability.hs b/tests/neg/Propability.hs
deleted file mode 100644
--- a/tests/neg/Propability.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-@ LIQUID "--prune-unsorted" @-}
-
-module Propability where
-
-{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}
-
-{-@ p :: Propability @-}
-p :: Double
-p = 0.8
-
-{-@ q :: Propability @-}
-q :: Double
-q = 1.8
-
-
-
-data DPD k = DPD [Pair k Double]
-
-data Pair x y = P x y
-{-@ data DPD k = DPD (val::{v:[Pair k Propability]|(total v) = 1.0 }) @-}
-
-{-@ measure total :: [Pair k Double] -> Double
- total([]) = 0.0
- total(x:xs) = (sndP x) + (total xs)
- @-}
-
-{-@ measure sndP :: (Pair x Double) -> Double
- sndP(P x y) = y
- @-}
-
-
-dpd0 :: DPD Int
-dpd0 = DPD [P 1 0.8, P 2 0.1, P 3 0.1]
-
-dpd1 :: DPD Int
-dpd1 = DPD [P 1 0.8, P 2 0.1, P 3 0.1, P 4 0.1]
diff --git a/tests/neg/Propability0.hs b/tests/neg/Propability0.hs
deleted file mode 100644
--- a/tests/neg/Propability0.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-
-{-@ LIQUID "--prune-unsorted" @-}
-
-module Propability where
-
-
-{- NIKI TO FIX:
- this should be SAFE but z3 doesnot like it because
- snd :: Int -> Int instead of
- snd :: Int -> Real
--}
-
-{-@ type Propability = {v:Double | ((0.0 <= v) && (v <= 1.0)) } @-}
-
-{-@ p :: Propability @-}
-p :: Double
-p = 0.8
-
-{-@ q :: Propability @-}
-q :: Double
-q = 1.8
-
-
-
-data DPD k = DPD [(k, Double)]
-
-{-@ data DPD k = DPD (val::{v:[(k, Propability)]|(total v) = 1.0 }) @-}
-
-{-@ measure total :: [(k, Double)] -> Double
- total([]) = 0.0
- total(x:xs) = (snd x) + (total xs)
- @-}
-
-
-
-dpd0 :: DPD Int
-dpd0 = DPD [(1, 0.9), (2, 0.1)]
diff --git a/tests/neg/QQTySig.hs b/tests/neg/QQTySig.hs
deleted file mode 100644
--- a/tests/neg/QQTySig.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Nats where
-
-import LiquidHaskell
-
-[lq| nats :: [{ v:Int | 0 <= v }] |]
-nats = [-1,0,1,2,3,4,5,6,7,8,9,10]
-
diff --git a/tests/neg/QQTySyn1.hs b/tests/neg/QQTySyn1.hs
deleted file mode 100644
--- a/tests/neg/QQTySyn1.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Nats where
-
-import LiquidHaskell
-
-[lq| type MyNat = { v:Int | 0 <= v } |]
-[lq| type MyList a N = { v:[a] | (len v) = N } |]
-
-[lq| nats :: MyList MyNat 12 |]
-nats = [0,1,2,3,4,5,6,7,8,9,10]
-
diff --git a/tests/neg/QQTySyn2.hs b/tests/neg/QQTySyn2.hs
deleted file mode 100644
--- a/tests/neg/QQTySyn2.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-
-module Nats where
-
-import LiquidHaskell
-
-[lq| type MyNat = { v:Int | 0 <= v } |]
-[lq| type MyList a N = { v:[a] | (len v) = N } |]
-
-[lq| nats :: MyList MyNat 11 |]
-nats = [-1,1,2,3,4,5,6,7,8,9,10]
-
diff --git a/tests/neg/RG.hs b/tests/neg/RG.hs
deleted file mode 100644
--- a/tests/neg/RG.hs
+++ /dev/null
@@ -1,135 +0,0 @@
-module RG where
-
-import Data.IORef as R
-
-{- Liquid Rely-Guarantee References / RG-Haskell
-
- This is an embedding of a slightly simplified rely-guarantee reference system.
- (See "Rely-Guarantee References for Refinement Types over Aliased Mutable Data,"
- by Gordon, Ernst, and Grossman, PLDI'13. I promise to never use such a long paper
- title ever again.)
-
- The key idea in that paper is to augment each reference with a predicate refining
- the referent and heap reachable from it, and binary relations describing permitted
- local actions (the guarantee) and possible remote actions (the rely):
-
- ref{T|P}[R,G]
-
- The terminology comes from rely-guarantee reasoning, from the concurrent program
- logic literature. As long as
- each reference's guarantee relation is a subrelation of any alias's rely (plus some
- subtle side conditions about nested references), any predicate P that is /stable/
- with respect to a rely R on a given reference (forall x y, P x -> R x y -> P y)
- is trivially preserved by any update through an alias that respects that alias's
- guarantee relation.
-
- Embedding into Liquid Haskell instead of Coq requires a few weakenings of the
- original design, so we lose expressiveness but gain substantially from automation
- and being a refinement of a language with real programs! The main simplifications are:
- - TEMPORARILY, rely and guarantee are the same, until we get rolling. In general,
- we must always have that the guarantee implies the rely, since Haskell wouldn't
- respect the substructural restrictions. Leaving them the same makes weakening the
- guarantee unsound, so we should fix this soon.
- - Predicates and relations can refer only to the immediate referent for now.
- - Folding (pushing a local restriction through to new references reached via
- dereference) doesn't exist in this system, mostly because all predicates and
- relations can restrict only one cell.
-
--}
-
-{- We wrap IORefs in a new constructor to add ghost parameters for the predicate and
- relation(s). It is a standard GHC optimization to eliminate the overhead since there is a single
- constructor with one physical argument, so at runtime these will look the same as IORefs:
- we won't pay time or space overhead. -}
-{-@ data RGRef a Bool, r :: a -> a -> Bool>
- = Wrap { rr :: IORef a } @-}
-data RGRef a = Wrap (R.IORef a)
-
-{- A stability proof can be embedded into LH as a function of type:
- x:a -> y:a | v = y}
- This encodes the requirement that knowing P x and R x y is sufficient to deduce P y.
--}
--- Requires explicit type anno for LH type to refine the inferred Haskell type
-{-@ stable_monocount :: x:{v:Int | v > 0 } -> y:{v:Int | x <= v } -> {v:Int | ((v = y) && (v > 0)) } @-}
-stable_monocount :: Int -> Int -> Int
-stable_monocount x y = y
-
--- Testing / debugging function
-{-@ generic_accept_stable :: forall Bool, r :: a -> a -> Bool >.
- f:(x:a -> y:a | (v = y)}) ->
- ()
- @-}
-generic_accept_stable :: (a -> a -> a) -> ()
-generic_accept_stable pf = ()
-
-{-@ proves_reflexivity :: x:{v:Int | v > 0} -> y:{v:Int | v > 0} -> {v:Int | v > 0} @-}
-proves_reflexivity :: Int -> Int -> Int
-proves_reflexivity x y = x
-
-test :: ()
-test = generic_accept_stable proves_reflexivity
-
-{-@ proves_nothing :: x:a -> y:a -> {v:a | (v = y)} @-}
-proves_nothing :: a -> a -> a
-proves_nothing x y = y --proves_nothing x y
-
-{- TODO: e2 is a hack to sidestep the inference of false for r,
- it forces r to be inhabited. -}
-{-@ newRGRef :: forall Bool, r :: a -> a -> Bool >.
- e:a ->
- e2:a -> y:a | (v = y)}) ->
- IO (RGRef Bool, r :: a -> a -> Bool >.
- RGRef ) @-}
-readRGRef (Wrap x) = readIORef x
-
--- TODO: full spec, fix pf type
-writeRGRef :: RGRef a -> a -> (a -> a -> Bool) -> IO ()
-writeRGRef (Wrap x) e pf = writeIORef x e
-
-
-{- modifyRGRef :: forall Bool, r :: a -> a -> Bool >.
- r:(RGRef -> a -> y:a | (v = y)}) ->
- IO () @-}
-modifyRGRef :: RGRef a -> (a -> a) -> (a -> a -> a) -> IO ()
-modifyRGRef (Wrap x) f pf = modifyIORef x (\ v -> pf v (f v))
---
---{- modifyRGRef' :: forall Bool, r :: a -> a -> Bool >.
--- RGRef -> a Bool, w :: a -> Bool -> Bool>.
- {y::a, b::{v:Bool }
- (x:a -> Bool ) @-}
-find :: (a -> Bool) -> [a] -> Maybe a
-find f [] = Nothing
-find f (x:xs) | f x = Just x
- | otherwise = Nothing
-
-cons x xs = (x:xs)
-nil = []
--- | Generate all assignments
-
-asgns :: Formula -> [Asgn] -- generates all possible T/F vectors
-asgns = go . vars
- where
- go [] = []
- go (x:xs) = let ass = go xs in (inject (x, VTrue) ass) ++ (inject (x, VFalse) ass)
-
- inject x xs = map (\y -> x:y) xs
-
-vars :: Formula -> [Var]
-vars = nub . go
- where
- go [] = []
- go (ls:xs) = map go' ls ++ go xs
-
- go' (Pos x) = x
- go' (Neg x) = x
-
--- | Satisfaction
-
-{-@ reflect sat @-}
-sat :: Asgn -> Formula -> Bool
-sat a [] = True
-sat a (c:cs) = satCls a c && sat a cs
-
-{-@ reflect satCls @-}
-satCls :: Asgn -> Clause -> Bool
-satCls a [] = False
-satCls a (l:ls) = satLit a l || satCls a ls
-
-
-{-@ reflect satLit @-}
-satLit :: Asgn -> Lit -> Bool
-satLit a (Pos x) = isTrue x a
-satLit a (Neg x) = isFalse x a
-
-{-@ reflect isTrue @-}
-isTrue :: Var -> Asgn -> Bool
-isTrue xisT (yv:as) = if xisT == (myFst yv) then (isVFalse (mySnd yv)) else isTrue xisT as
-isTrue _ [] = False
-
-{-@ reflect isFalse @-}
-isFalse :: Var -> Asgn -> Bool
-isFalse xisF (yv:as) = if xisF == (myFst yv) then (isVFalse (mySnd yv)) else isFalse xisF as
-isFalse _ [] = False
-
-{-@ measure isVTrue @-}
-isVTrue :: Val -> Bool
-isVTrue VTrue = True
-isVTrue VFalse = False
-
-{-@ measure isVFalse @-}
-isVFalse :: Val -> Bool
-isVFalse VFalse = True
-isVFalse VTrue = False
-
-{-@ measure myFst @-}
-myFst :: (a, b) -> a
-myFst (x, y) = x
-
-{-@ measure mySnd @-}
-mySnd :: (a, b) -> b
-mySnd (x, y) = y
diff --git a/tests/neg/StateConstraints.hs b/tests/neg/StateConstraints.hs
deleted file mode 100644
--- a/tests/neg/StateConstraints.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module Compose where
-
-data ST s = ST {runState :: s -> s}
-
-{-@ data ST s Bool, q :: s -> s -> Bool> = ST (runState :: x:s -> s Bool, q :: s -> s -> Bool>. ST -> s Bool, q :: s -> s -> Bool, r :: s -> a -> Bool>
- = ST (runState :: x:s -> (a Bool, q :: s -> s -> Bool, r :: s -> a -> Bool>. ST -> (a Bool >. x:a -> ST |- c
)
@@ -136,7 +286,7 @@
LiquidHaskell now *requires* ghc-7.8.3.
- Termination
-LiquidHaskell will now attempt to prove all recursive functions terminating. It tries to prove that some parameter (or combination thereof) decreases at each recursive callsite. By default, this will be the first parameter with an associated size measure (see Size Measures), but can be overridden with the `Decreases` annotation or a termination expression (see Termination Expressions).
+LiquidHaskell will now attempt to prove all recursive functions terminating. It tries to prove that some parameter (or combination thereof) decreases at each recursive callsite. By default, this will be the first parameter with an associated size measure (see Size Measures), but can be overridden with the `Decreases` annotation or a termination expression (see Termination Expressions).
If proving termination is too big of burden, it can be disabled on a per-module basis with the `--no-termination` flag, or on a per-function basis with the `Lazy` annotation.
@@ -207,7 +357,7 @@
We have greatly improved our parser to require fewer parentheses! Yay!
- Emacs/Vim Support
-LiquidHaskell now comes with syntax checkers for [flycheck](https://github.com/flycheck/flycheck) in Emacs and [syntastic](https://github.com/scrooloose/syntastic) in Vim.
+LiquidHaskell now comes with syntax checkers for [flycheck](https://github.com/flycheck/flycheck) in Emacs and [syntastic](https://github.com/scrooloose/syntastic) in Vim.
- Incremental Checking
LiquidHaskell has a new `--diffcheck` flag that will only check binders that have changed since the last run, which can drastically improve verification times.
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,27 +1,407 @@
+[](https://hackage.haskell.org/package/liquidhaskell) []([https://circleci.com/gh/ucsd-progsys/liquidhaskell](https://app.circleci.com/pipelines/github/ucsd-progsys/liquidhaskell?branch=develop))
-[](https://hackage.haskell.org/package/liquidhaskell) [](http://packdeps.haskellers.com/feed?needle=liquidhaskell) [](https://circleci.com/gh/ucsd-progsys/liquidhaskell)
-[](https://ci.appveyor.com/project/varosi/liquidhaskell-nlhra/branch/develop)
+This is the **development** site of the LiquidHaskell formal verification tool.
-## Quick Links
+If you're a LiquidHaskell **user** (or just curious), you probably want to go to [the documentation website](https://ucsd-progsys.github.io/liquidhaskell/) instead.
-* [Try LiquidHaskell in your browser](http://goto.ucsd.edu:8090/index.html)
-* [Splash page with examples and link to blog](https://ucsd-progsys.github.io/liquidhaskell-blog/)
-* [120 minute workshop with more examples](http://ucsd-progsys.github.io/lh-workshop/01-index.html)
-* [Long ish Tutorial](http://ucsd-progsys.github.io/liquidhaskell-tutorial/)
+## Trying it from Hackage
-## Documentation
+Assuming the [Z3](https://github.com/Z3Prover/z3) SMT solver version `4.8.17` or
+newer is installed and available in your `PATH`, you can run
-* [LH Documentation](http://ucsd-progsys.github.io/liquidhaskell/)
-* [Edit here](/docs/mkDocs)
+```
+cabal install --lib liquidhaskell liquid-prelude liquid-vector --package-env . --force-reinstalls
+ghc -fplugin=LiquidHaskell FILE.hs
+```
-## Questions
+`--package-env .` creates a `.ghc.environment*` file in the current folder that makes
+`ghc` find the `LiquidHaskell` plugin only when invoking it from there.
+Otherwise, global user configuration would be affected.
-If you have any questions
+Note that the installation step is influenced by the dependencies that are
+already installed in your system, so different results may be obtained by
+different users.
-* Join the Liquid Haskell [slack channel](https://join.slack.com/t/liquidhaskell/shared_invite/enQtMjY4MTk3NDkwODE3LTFmZGFkNGEzYWRkNDJmZDQ0ZGU1MzBiZWZiZDhhNmY3YTJiMjUzYTRlNjMyZDk1NDU3ZGIxYzhlOTIzN2UxNWE)
-* Mail the [users mailing list](https://groups.google.com/forum/#!forum/liquidhaskell)
-* Create a github issue
+## Trying it from GitHub
+The github repo builds with GHC `9.14.1`, cabal-install `3.16.1.0`, and `z3` `9.8.17` or newer, all of
+which must be in your `PATH`.
+
+```
+git clone https://github.com/ucsd-progsys/liquidhaskell.git
+cd liquidhaskell
+git submodule update --init
+cabal build liquidhaskell liquid-prelude liquid-vector
+
+cabal exec -- ghc -fplugin=LiquidHaskell FILE.hs
+```
+
+## Asking for Help
+
+If you have questions or you just need help, you can always reach out on our [zulip space](https://liquidhaskell.zulipchat.com/), [google groups mailing list](https://groups.google.com/forum/#!forum/liquidhaskell), [GitHub issue tracker](https://github.com/ucsd-progsys/liquidhaskell/issues), or by emailing [Ranjit Jhala](https://github.com/ranjitjhala), [Niki Vazou](https://github.com/nikivazou).
+
+# Contributing
+
+This is an open-source project, and we love getting feedback (and patches)!
+
+## Reporting a Bug
+
+If something doesn't work as it should, please consider opening a [github issue](https://github.com/ucsd-progsys/liquidhaskell/issues)
+to let us know. If possible, try to:
+
+* Try to use a descriptive title;
+* State as clearly as possible what is the problem you are facing;
+* Provide a small Haskell file producing the issue;
+* Write down the expected behaviour vs the actual behaviour;
+* Please, let us know which liquidhaskell version you are using.
+
+## Your first Pull Request
+
+We are thrilled to get PRs! Please follow these guidelines, as doing so will increase the chances of
+having your PR accepted:
+
+* The main LH repo [lives here](https://github.com/ucsd-progsys/liquidhaskell)
+* Please create pull requests against the `develop` branch.
+* Please be sure to include test cases that illustrate the effect of the PR
+ - e.g. show new features that that are supported or how it fixes some previous issue
+* If you're making user-visible changes, please also add documentation
+ - e.g. [options.md](docs/mkDocs/docs/options.md), [specifications.md](docs/mkDocs/docs/specifications.md), the [main tutorial](https:///github.com/ucsd-progsys/intro-refinement-types) (as relevant)
+
+Pull requests don't just have to be about code: documentation can often be improved too!
+
+# General Development Guide
+
+For those diving into the implementation of LiquidHaskell, here are a few tips:
+
+## Faster recompilation
+
+When changing the `liquidhaskell-boot` library, sometimes we don't want
+to rebuild `liquidhaskell` or `liquid-vector` when testing the changes.
+In these cases we can set the environment variable `LIQUID_DEV_MODE=true`
+when running `cabal` to skip rebuilding those packages.
+
+DANGER: Note that this can give an invalid result if the changes to
+`liquidhaskell-boot` do require rebuilding other `liquid*` packages.
+
+## How To Run Regression Tests
+
+For documentation on the `test-driver` executable itself, please refer to the
+`README.md` in `tests/` or run `cabal run tests:test-driver -- --help`
+
+You can run *all* the tests by
+
+ $ ./scripts/test/test_plugin.sh
+
+You can run a bunch of particular test-groups instead by
+
+ $ ./scripts/test/test_plugin.sh
|- c
)
- -> xcmp:a -> c
|- c
)
+ -> xcmp:a -> c
"
- , "Interactive Solution based on Gradual Typing"
- ]
-
-htmlClose :: String
-htmlClose = "\n\n"
diff --git a/src/Gradual/GUI/Misc.hs b/src/Gradual/GUI/Misc.hs
deleted file mode 100644
--- a/src/Gradual/GUI/Misc.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Gradual.GUI.Misc where
-
-script :: String -> String
-script src = "\n"
diff --git a/src/Gradual/GUI/Types.hs b/src/Gradual/GUI/Types.hs
deleted file mode 100644
--- a/src/Gradual/GUI/Types.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-module Gradual.GUI.Types where
-
-import Language.Haskell.HsColour.Classify (TokenType)
-import Language.Haskell.Liquid.GHC.Misc (Loc(..))
-
-import qualified Data.HashMap.Strict as M
-import Language.Fixpoint.Types.Refinements hiding (L)
-import Language.Fixpoint.Types.Spans hiding (Loc(..))
-import Language.Fixpoint.Types (symbolString, Symbol)
-import qualified Data.List as L
-import qualified Data.Char as C
-import Data.Maybe (fromJust, fromMaybe)
-
-
-import Gradual.Types
-import Gradual.PrettyPrinting
-
-
-data Unique = Unique {uId :: Int, uLoc :: SrcSpan, uName :: Symbol}
-type LocTokens = [(TokenType, String, Loc)]
-type Deps = Dependencies () -- [(Int, [SrcSpan])]
-type SDeps = Dependencies String
-type Dependencies val = [(Unique, [(Unique,val)])]
-type PKeys = [[KVar]]
-
-makePKeys :: [[GSub a]] -> PKeys
-makePKeys sols = M.keys <$> head <$> sols
-
-instance Show Unique where
- show u = show (uLoc u)
-
-kVarId :: Dependencies v -> KVar -> (Int, Int)
-kVarId deps k = fromMaybe (0,0) $ L.lookup (kv k)
- [(uName x,(uId ui, uId x)) | (ui, xs) <- deps, (x,_) <- xs]
-
-srcDeps :: Dependencies v -> [(Int, Int, SrcSpan, v)]
-srcDeps deps = [(uId ui, uId x, uLoc x, v) | (ui, xs) <- deps , (x,v) <- xs]
-
-
-gSpanToDeps :: GSub a -> GSpan -> SDeps
-gSpanToDeps sol gm = [(Unique i (kVarSpan $ kv k) (kv k), mapValues ks)
- | ((k,ks),i) <- zip gml [1..]]
- where
- mapValues ks = [(Unique i s $ kv k, lookSol k) | ((k,Just s), i) <- zip ks [1..]]
- gml = L.sortBy (\(k1,_) (k2,_) -> compare (kVarSpan $ kv k1) (kVarSpan $ kv k2))
- $ M.toList gm
- lookSol k = fromMaybe "NA" (pretty . snd <$> M.lookup k sol)
-
-
-
-kVarSpan :: Symbol -> SrcSpan
-kVarSpan k = SS lc lc
- where
- L (l, c) = symbolLoc k
- fn = takeFileName $ symbolString k
- lc = toSourcePos (fn, l, c)
-
-takeFileName :: String -> String
-takeFileName ('$':xs) = takeWhile (/= ' ') xs
-takeFileName _ = ""
-
-symbolLoc :: Symbol -> Loc
-symbolLoc x = L (read line, read col)
- where
- (line, rest) = spanAfter C.isDigit "line " (symbolString x)
- (col, _) = spanAfter C.isDigit "column " rest
- spanAfter p str input = L.span p $ fromJust $ L.stripPrefix str $
- head $ filter (L.isPrefixOf str) $ L.tails input
diff --git a/src/Gradual/Misc.hs b/src/Gradual/Misc.hs
deleted file mode 100644
--- a/src/Gradual/Misc.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{-# LANGUAGE TupleSections #-}
-
-module Gradual.Misc where
-
-import Control.Monad (filterM)
-
--------------------------------------------------------------------------------
--- | Mapping ------------------------------------------------------------------
--------------------------------------------------------------------------------
-
-mapThd3 :: (c -> d) -> (a, b, c) -> (a, b, d)
-mapThd3 f (x, y, z) = (x, y, f z)
-
-mapSndM :: Functor m => (b -> m c) -> (a,b) -> m (a, c)
-mapSndM f (x,y) = (x,) <$> f y
-
-
-mapMWithLog :: String -> (a -> IO b) -> [a] -> IO [b]
-mapMWithLog msg f xs = go 1 xs
- where
- n = length xs
-
- go _ [] = return []
- go i (x:xs) = do
- putStrLn (msg ++ " [" ++ show i ++ "/" ++ show n ++ "]...")
- r <- f x
- rs <- go (i+1) xs
- return (r:rs)
-
--------------------------------------------------------------------------------
--- | Powersets ----------------------------------------------------------------
--------------------------------------------------------------------------------
-
-powersetUpTo :: Int -> [a] -> [[a]]
-powersetUpTo 0 _ = []
-powersetUpTo 1 xs = (:[]) <$> xs
-powersetUpTo i xs = filter ((i >=) . length) $ filterM (const [False, True]) xs
-
--------------------------------------------------------------------------------
--- | Combining ----------------------------------------------------------------
--------------------------------------------------------------------------------
-
-
-flatten :: [(k,(i,[v]))] -> [[(k,(i, v))]]
-flatten kvs = allCombinations ((\(k,(i,vs)) -> ((k,) . (i,)) <$> vs)<$> kvs)
-
-expand :: (a -> [a]) -> [a] -> [[a]]
-expand f xs = allCombinations (f <$> xs)
-
-expand2 :: (b -> [b]) -> [(a, b)] -> [[(a,b)]]
-expand2 f xs = zip x1s <$> allCombinations x2s
- where
- (x1s,x2s) = unzip ((\(x,y) -> (x,f y)) <$> xs)
-
-expand3 :: (c -> [c]) -> [(a,b,c)] -> [[(a,b,c)]]
-expand3 f xs = zip3 x1s x2s <$> allCombinations x3s
- where
- (x1s,x2s,x3s) = unzip3 ((\(x,y,z) -> (x,y,f z)) <$> xs)
-
-{-@ allCombinations :: xss:[[a]] -> [{v:[a]| len v == len xss}] @-}
-allCombinations :: [[a]] -> [[a]]
-allCombinations xs = assert (and . map (((length xs) == ) . length)) $ go xs
- where
- go [] = [[]]
- go [[]] = []
- go ([]:_) = []
- go ((x:xs):ys) = ((x:) <$> go ys) ++ go (xs:ys)
-
- assert b x = if b x then x else error "allCombinations: assertion violation"
diff --git a/src/Gradual/PrettyPrinting.hs b/src/Gradual/PrettyPrinting.hs
deleted file mode 100644
--- a/src/Gradual/PrettyPrinting.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-module Gradual.PrettyPrinting where
-
-import Language.Fixpoint.Types
-import Language.Haskell.Liquid.GHC.Misc
-
-
-class Pretty a where
- pretty :: a -> String
-
-instance Pretty Expr where
- pretty = showpp . simplifyExpr
-
-instance Pretty KVar where
- pretty (KV x) = pretty x
-
-instance Pretty Symbol where
- pretty = show . dropModuleNames. tidySymbol
-
-instance (Pretty a, Pretty b) => Pretty (a, b) where
- pretty (x,y) = pretty x ++ " |-> " ++ pretty y
-
-instance (Pretty a) => Pretty [a] where
- pretty xs = unlines $ map pretty xs
-
-simplifyExpr :: Expr -> Expr
-simplifyExpr = go
- where
- go (ECst e _) = go e
- go (EApp e1 e2)
- | EVar x <- go e1
- , x `elem` [applyName, toIntName, setToIntName, bitVecToIntName, mapToIntName, realToIntName]
- = go e2
- go (EApp e1 e2)
- = EApp (go e1) (go e2)
- go (ENeg e) = ENeg (go e)
- go (EBin b e1 e2) = EBin b (go e1) (go e2)
- go (EIte e e1 e2) = EIte (go e) (go e1) (go e2)
- go (PAnd es) = PAnd (go <$> es)
- go (POr es) = POr (go <$> es)
- go (PNot e) = PNot (go e)
- go (PImp e1 e2) = PImp (go e1) (go e2)
- go (PIff e1 e2) = PIff (go e1) (go e2)
- go (PAtom a e1 e2) = PAtom a (go e1) (go e2)
- go (PAll a e) = PAll a (go e)
- go (PExist a e) = PExist a (go e)
- go (ETApp e a) = ETApp (go e) a
- go (ELam a e) = ELam a (go e)
- go (EVar x) = EVar (dropModuleNames $ tidySymbol x)
- go e = e
diff --git a/src/Gradual/Refinements.hs b/src/Gradual/Refinements.hs
deleted file mode 100644
--- a/src/Gradual/Refinements.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-module Gradual.Refinements (makeGMap) where
-
-import Gradual.Types
-import Gradual.Misc
--- import Gradual.PrettyPrinting
-
-import Language.Fixpoint.Types
-import Language.Fixpoint.Types.Config
-import Language.Fixpoint.Solver.Monad
-import Language.Fixpoint.Solver.Solve (solverInfo)
-import Language.Fixpoint.Utils.Files
-import Language.Fixpoint.SortCheck (exprSort_maybe)
-
-
-import Control.Monad (filterM)
--- import Control.Monad.IO.Class
-
-makeGMap :: GConfig -> Config -> SInfo a -> [(KVar, (GWInfo, [Expr]))] -> IO (GMap GWInfo)
-makeGMap gcfg cfg sinfo mes = toGMap <$> runSolverM cfg' sI act
- where
- sI = solverInfo cfg' sinfo
- act = mapM (concretize gcfg) mes
- cfg' = cfg { srcFile = srcFile cfg `withExt` Pred
- , gradual = True -- disable mbqi
- }
-
-concretize :: GConfig -> (KVar, (GWInfo, [Expr])) -> SolveM (KVar, (GWInfo,[Expr]))
-concretize cfg (kv, (info, es))
- = (\es' -> (kv,(info,es'))) <$>
- filterM (isGoodInstance info)
- (PTrue:(pAnd <$> powersetUpTo (depth cfg) es))
-
-isGoodInstance :: GWInfo -> Expr -> SolveM Bool
-isGoodInstance info e
- | isSensible e -- heuristic to delete stupit instantiations
- = (&&) <$> (isLocal info e) <*> (isMoreSpecific info e)
- | otherwise
- = return False
-
-isSensible :: Expr -> Bool
-isSensible (PIff _ (PAtom _ e1 e2))
- | e1 == e2
- = False
-isSensible (PAtom cmp e _)
- | cmp `elem` [Gt,Ge,Lt,Le]
- , Just s <- exprSort_maybe e
- , boolSort == s
- = False
-isSensible _
- = True
-
-isLocal :: GWInfo -> Expr -> SolveM Bool
-isLocal i e = isValid (PExist [(gsym i, gsort i)] e)
-
-isMoreSpecific :: GWInfo -> Expr -> SolveM Bool
-isMoreSpecific i e = isValid (pAnd [e, gexpr i] `PImp` gexpr i)
-
-
-isValid :: Expr -> SolveM Bool
-isValid e
- | isContraPred e = return False
- | isTautoPred e = return True
- | PImp (PAnd es) e2 <- e
- , e2 `elem` es = return True
-isValid e = not <$> checkSat (PNot e)
-
diff --git a/src/Gradual/Trivial.hs b/src/Gradual/Trivial.hs
deleted file mode 100644
--- a/src/Gradual/Trivial.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Gradual.Trivial (simplify) where
-
-import Language.Fixpoint.Types hiding (simplify)
-import qualified Data.HashMap.Strict as M
-
-
-simplify :: SInfo a -> SInfo a
-simplify sinfo = sinfo {cm = M.map f (cm sinfo)}
- where
- f c | PGrad _ _ _ e <- _crhs c
- = c { _crhs = e}
- f c = c
diff --git a/src/Gradual/Types.hs b/src/Gradual/Types.hs
deleted file mode 100644
--- a/src/Gradual/Types.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-module Gradual.Types where
-
-
-import qualified Language.Haskell.Liquid.UX.Config as C
-import Language.Fixpoint.Types
-
-import qualified Data.HashMap.Strict as M
-
-data GConfig = GConfig {gtarget :: String, depth :: Int, pId :: Int, pNumber :: Int}
-
-defConfig :: GConfig
-defConfig = GConfig "" 0 0 0
-
-setPId :: GConfig -> Int -> GConfig
-setPId cfg i = cfg {pId = i}
-
-makeGConfig :: C.Config -> GConfig
-makeGConfig cfg = defConfig {depth = C.gdepth cfg, gtarget = head $ C.files cfg}
-
-
-
-type GSub a = M.HashMap KVar (a, Expr)
-type GMap a = M.HashMap KVar (a, [Expr])
-type GSpan = M.HashMap KVar [(KVar, Maybe SrcSpan)]
-
-toGMap :: [(KVar, (a, [Expr]))] -> GMap a
-toGMap = M.fromList
-
-fromGMap :: GMap a -> [(KVar, (a, [Expr]))]
-fromGMap = M.toList
-
-
-fromGSub :: GSub a -> [(KVar, (a, Expr))]
-fromGSub = M.toList
-
-
-removeInfo :: GMap a -> GMap ()
-removeInfo = M.map (\(_,x) -> ((),x))
diff --git a/src/Gradual/Uniquify.hs b/src/Gradual/Uniquify.hs
deleted file mode 100644
--- a/src/Gradual/Uniquify.hs
+++ /dev/null
@@ -1,263 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE TupleSections #-}
-
-module Gradual.Uniquify (uniquify) where
-
-import Language.Fixpoint.Types.Refinements
-import Language.Fixpoint.Types.Constraints
-import Language.Fixpoint.Types.PrettyPrint
-import Language.Fixpoint.Types.Environments
-import Language.Fixpoint.Types.Visitor
-import Language.Fixpoint.Types.Spans
-import Language.Fixpoint.Types.Names (gradIntSymbol)
-
-import Control.DeepSeq
-
-import qualified Data.HashMap.Strict as M
-import qualified Data.List as L
-
-import Control.Monad.State.Lazy
-
-import Gradual.Types (GSpan)
-
--------------------------------------------------------------------------------
--- | Make each gradual appearance unique -------------------------------------
--------------------------------------------------------------------------------
-
-uniquify :: (NFData a, Fixpoint a, Loc a) => SInfo a -> (GSpan, SInfo a)
-
-uniquify fi = (km', fi{cm = cm', ws = ws', bs = bs'})
- where
- (cm', km, bs') = uniquifyCS (bs fi) (cm fi)
- ws' = expandWF km (ws fi)
- km' = M.union km $ M.map (const []) $ M.filter isGradual (ws fi)
-
-uniquifyCS :: (NFData a, Fixpoint a, Loc a)
- => BindEnv
- -> M.HashMap SubcId (SimpC a)
- -> (M.HashMap SubcId (SimpC a), GSpan, BindEnv)
-uniquifyCS bs cs = (x, km, benv st)
- where
- (x, st) = runState (uniq cs) (initUniqueST bs)
- km = kmap st
-
-class Unique a where
- uniq :: a -> UniqueM a
-
-instance Unique a => Unique (M.HashMap SubcId a) where
- uniq m = M.fromList <$> mapM (\(i,x) -> (i,) <$> uniq x) (M.toList m)
-
-instance Loc a => Unique (SimpC a) where
- uniq cs = do
- updateLoc $ srcSpan $ _cinfo cs
- rhs <- uniq (_crhs cs)
- env <- uniq (_cenv cs)
- return cs{_crhs = rhs, _cenv = env}
-
-instance Unique IBindEnv where
- uniq env = withCache (fromListIBindEnv <$> mapM uniq (elemsIBindEnv env))
-
-instance Unique BindId where
- uniq i = do
- bs <- benv <$> get
- let (x, t) = lookupBindEnv i bs
- resetChange
- t' <- uniq t
- hasChanged <- change <$> get
- if hasChanged
- then do let (i', bs') = insertBindEnv x t' bs
- updateBEnv i bs'
- return i'
- else return i
-
-instance Unique SortedReft where
- uniq (RR s r) = RR s <$> uniq r
-
-instance Unique Reft where
- uniq (Reft (x,e)) = (Reft . (x,)) <$> uniq e
-
-instance Unique Expr where
- uniq = mapMExpr go
- where
- go (PGrad k su i e) = do
- k' <- freshK k
- src <- uloc <$> get
- return $ PGrad k' su (i{gused = src}) e
- go e = return e
-
--------------------------------------------------------------------------------
--- | The Unique Monad ---------------------------------------------------------
--------------------------------------------------------------------------------
-
-type UniqueM = State UniqueST
-data UniqueST
- = UniqueST { freshId :: Integer
- , kmap :: GSpan
- , change :: Bool
- , cache :: M.HashMap KVar KVar
- , uloc :: Maybe SrcSpan
- , ubs :: [BindId]
- , benv :: BindEnv
- }
-
-
-
-updateLoc :: SrcSpan -> UniqueM ()
-updateLoc x = modify $ \s -> s{uloc = Just x}
-
-withCache :: UniqueM a -> UniqueM a
-withCache act = do
- emptyCache
- a <- act
- emptyCache
- return a
-
-emptyCache :: UniqueM ()
-emptyCache = modify $ \s -> s{cache = mempty}
-
-
-updateBEnv :: BindId -> BindEnv -> UniqueM ()
-updateBEnv i bs = modify $ \s -> s{benv = bs, ubs = i:(ubs s)}
-
-setChange :: UniqueM ()
-setChange = modify $ \s -> s{change = True}
-
-resetChange :: UniqueM ()
-resetChange = modify $ \s -> s{change = False}
-
-initUniqueST :: BindEnv -> UniqueST
-initUniqueST = UniqueST 0 mempty False mempty Nothing mempty
-
-freshK, freshK', freshK'' :: KVar -> UniqueM KVar
-freshK k = do
- setChange
- cached <- cache <$> get
- case M.lookup k cached of
- {- OPTIMIZATION: Only create one fresh occurrence of ? per constraint environment. -}
- Just k' -> return k'
- Nothing -> freshK'' k
-
--- M.HashMap KVar [(KVar, Maybe SrcSpan)]
-
-freshK'' k = do
- curr <- kmap <$> get
- loc <- uloc <$> get
- case M.lookup k curr of
- Nothing -> freshK' k
- Just xs -> do spans <- existingSpan k loc xs
- case spans of
- Just k' -> return k'
- Nothing -> freshK' k
-
-
-{-
-Interesting Relative Positions
-
- [.......]
-Ouside | [..]
-Inside [............]
-Smaller [..............]
-Greater [....]
-
--}
-
-data RelativePos a
- = Outside a
- | Inside a
- | Smaller a
- | Greater a
- | NoRelative
-
-existingSpan :: KVar -> Maybe SrcSpan -> [(KVar, Maybe SrcSpan)] -> UniqueM (Maybe KVar)
-existingSpan _ Nothing _ = return Nothing
-existingSpan k (Just span) kspans
- = case go kspans of
- Inside (k',_) -> updateK k k' span >> (return $ Just k')
- Outside (k',sp) -> updateLoc sp >> (return $ Just k')
- Smaller (k',sp) -> updateK k k' (sp `spanDiff` span) >> (return $ Just k')
- Greater (k',sp) -> updateLoc (sp `spanDiff` span) >> (return $ Just k')
- NoRelative -> return Nothing
-
- where
- go [] = NoRelative
- go ((_,Nothing):sps) = go sps
- go ((x,Just sp):sps)
- | span `inSpan` sp = Inside (x, sp)
- | sp `inSpan` span = Outside (x, sp)
- | span `isSmaller` sp = Smaller (x, sp)
- | sp `isSmaller` span = Greater (x, sp)
- | otherwise = go sps
-
-
-
-spanDiff :: SrcSpan -> SrcSpan -> SrcSpan
-spanDiff (SS _ end1) (SS _ end2) = SS (toSourcePos (f,l,c-1)) end2
- where (f,l,c) = sourcePosElts end1
-
-inSpan :: SrcSpan -> SrcSpan -> Bool
-inSpan (SS start1 end1) (SS start2 end2)
- = start1' > start2' && end1' <= end2'
- where
- [start1',start2',end1',end2'] = sourcePosElts <$> [start1,start2,end1,end2]
-
-
-isSmaller :: SrcSpan -> SrcSpan -> Bool
-isSmaller (SS start1 end1) (SS start2 end2)
- = start1' == start2' && end1' <= end2'
- where
- [start1',start2',end1',end2'] = sourcePosElts <$> [start1,start2,end1,end2]
-
-
-freshK' k = do
- i <- freshId <$> get
- modify $ (\s -> s{freshId = i + 1})
- let k' = KV $ gradIntSymbol i
- addK k k'
- addCache k k'
- return k'
-
-
-updateK :: KVar -> KVar -> SrcSpan -> UniqueM ()
-updateK k k' sp =
- modify $ (\s -> s{kmap = M.mapWithKey f (kmap s)})
- where
- f key val
- | key == k = (\(kk,vv) -> if kk == k' then (kk,Just sp) else (kk,vv)) <$> val
- | otherwise = val
-
-addK :: KVar -> KVar -> UniqueM ()
-addK key val =
- modify $ (\s -> s{kmap = M.insertWith (++) key [(val, uloc s)] (kmap s)})
-
-addCache :: KVar -> KVar -> UniqueM ()
-addCache k k' = modify $ \s -> s{cache = M.insert k k' (cache s)}
-
--------------------------------------------------------------------------------
--- | expandWF -----------------------------------------------------------------
--------------------------------------------------------------------------------
-
-expandWF :: (NFData a, Fixpoint a)
- => GSpan
- -> M.HashMap KVar (WfC a)
- -> M.HashMap KVar (WfC a)
-expandWF km ws
- = M.fromList $
- ([(k, updateKVar k src w) | (i, w) <- gws, (kw, ks) <- km', kw == i, (k, src) <- ks]
- ++ kws)
- where
- (gws, kws) = L.partition (isGWfc . snd) $ M.toList ws
- km' = M.toList km
- updateKVar k src wfc = wfc { wrft = (\(v,s,_) -> (v,s,k)) $ wrft wfc
- , wloc = (wloc wfc){gused = src}
- }
-
diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare.hs
+++ /dev/null
@@ -1,1093 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module contains the functions that convert /from/ descriptions of
--- symbols, names and types (over freshly parsed /bare/ Strings),
--- /to/ representations connected to GHC 'Var's, 'Name's, and 'Type's.
--- The actual /representations/ of bare and real (refinement) types are all
--- in 'RefType' -- they are different instances of 'RType'.
-
-module Language.Haskell.Liquid.Bare (
- -- * Creating a TargetSpec
- -- $creatingTargetSpecs
- makeTargetSpec
-
- -- * Loading and Saving lifted specs from/to disk
- , loadLiftedSpec
- , saveLiftedSpec
- ) where
-
-import Prelude hiding (error)
-import Optics
-import Control.Monad (unless)
-import qualified Control.Exception as Ex
-import qualified Data.Binary as B
-import qualified Data.Maybe as Mb
-import qualified Data.List as L
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-import Text.PrettyPrint.HughesPJ hiding (first, (<>)) -- (text, (<+>))
-import System.FilePath (dropExtension)
-import System.Directory (doesFileExist)
-import System.Console.CmdArgs.Verbosity (whenLoud)
-import Language.Fixpoint.Utils.Files as Files
-import Language.Fixpoint.Misc as Misc
-import Language.Fixpoint.Types hiding (dcFields, DataDecl, Error, panic)
-import qualified Language.Fixpoint.Types as F
-import qualified Language.Haskell.Liquid.Misc as Misc -- (nubHashOn)
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import Language.Haskell.Liquid.GHC.Types (StableName)
-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.Resolve as Bare
-import qualified Language.Haskell.Liquid.Bare.DataType as Bare
-import qualified Language.Haskell.Liquid.Bare.Expand as Bare
-import qualified Language.Haskell.Liquid.Bare.Measure as Bare
-import qualified Language.Haskell.Liquid.Bare.Plugged as Bare
-import qualified Language.Haskell.Liquid.Bare.Axiom as Bare
-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 Control.Arrow (second)
-
---------------------------------------------------------------------------------
--- | De/Serializing Spec files
---------------------------------------------------------------------------------
-
-loadLiftedSpec :: Config -> FilePath -> IO (Maybe Ms.BareSpec)
-loadLiftedSpec cfg srcF
- | noLiftedImport cfg = putStrLn "No LIFTED Import" >> return Nothing
- | otherwise = do
- let specF = extFileName BinSpec srcF
- ex <- doesFileExist specF
- whenLoud $ putStrLn $ "Loading Binary Lifted Spec: " ++ specF ++ " " ++ "for source-file: " ++ show srcF ++ " " ++ show ex
- lSp <- if ex
- then Just <$> B.decodeFile specF
- else (warnMissingLiftedSpec srcF specF >> return Nothing)
- Ex.evaluate lSp
-
-warnMissingLiftedSpec :: FilePath -> FilePath -> IO ()
-warnMissingLiftedSpec srcF specF = do
- incDir <- Misc.getIncludeDir
- unless (Misc.isIncludeFile incDir srcF)
- $ Ex.throw (errMissingSpec srcF specF)
-
-errMissingSpec :: FilePath -> FilePath -> UserError
-errMissingSpec srcF specF = ErrNoSpec Ghc.noSrcSpan (text srcF) (text specF)
-
--- saveLiftedSpec :: FilePath -> ModName -> Ms.BareSpec -> IO ()
-saveLiftedSpec :: FilePath -> Ms.BareSpec -> IO ()
-saveLiftedSpec srcF lspec = do
- ensurePath specF
- B.encodeFile specF lspec
- -- print (errorP "DIE" "HERE" :: String)
- where
- specF = extFileName BinSpec srcF
-
-{- $creatingTargetSpecs
-
-/Liquid Haskell/ operates on 'TargetSpec's, so this module provides a single function called
-'makeTargetSpec' to produce a 'TargetSpec', alongside the 'LiftedSpec'. The former will be used by
-functions like 'liquid' or 'liquidOne' to verify our program is correct, the latter will be serialised
-to disk so that we can retrieve it later without having to re-check the relevant Haskell file.
--}
-
--- | 'makeTargetSpec' constructs the 'TargetSpec' and then validates it. Upon success, the 'TargetSpec'
--- and the 'LiftedSpec' are returned. We perform error checking in \"two phases\": during the first phase,
--- we check for errors and warnings in the input 'BareSpec' and the dependencies. During this phase we ideally
--- want to short-circuit in case the validation failure is found in one of the dependencies (to avoid
--- printing potentially endless failures).
--- The second phase involves creating the 'TargetSpec', and returning either the full list of diagnostics
--- (errors and warnings) in case things went wrong, or the final 'TargetSpec' and 'LiftedSpec' together
--- with a list of 'Warning's, which shouldn't abort the compilation (modulo explicit request from the user,
--- to treat warnings and errors).
-makeTargetSpec :: Config
- -> LogicMap
- -> TargetSrc
- -> BareSpec
- -> TargetDependencies
- -> Either Diagnostics ([Warning], TargetSpec, LiftedSpec)
-makeTargetSpec cfg lmap targetSrc bareSpec dependencies = do
- let depsDiagnostics = mapM (uncurry Bare.checkBareSpec) legacyDependencies
- let bareSpecDiagnostics = Bare.checkBareSpec (giTargetMod targetSrc) legacyBareSpec
- case depsDiagnostics >> bareSpecDiagnostics of
- Left d | noErrors d -> secondPhase (allWarnings d)
- Left d -> Left d
- Right () -> secondPhase mempty
- where
- secondPhase :: [Warning] -> Either Diagnostics ([Warning], TargetSpec, LiftedSpec)
- secondPhase phaseOneWarns = do
- (warns, ghcSpec) <- makeGhcSpec cfg (review targetSrcIso targetSrc) lmap (allSpecs legacyBareSpec)
- let (targetSpec, liftedSpec) = view targetSpecGetter ghcSpec
- pure (phaseOneWarns <> warns, targetSpec, liftedSpec)
-
- toLegacyDep :: (StableModule, LiftedSpec) -> (ModName, Ms.BareSpec)
- toLegacyDep (sm, ls) = (ModName SrcImport (Ghc.moduleName . unStableModule $ sm), unsafeFromLiftedSpec ls)
-
- toLegacyTarget :: Ms.BareSpec -> (ModName, Ms.BareSpec)
- toLegacyTarget validatedSpec = (giTargetMod targetSrc, validatedSpec)
-
- legacyDependencies :: [(ModName, Ms.BareSpec)]
- legacyDependencies = map toLegacyDep . M.toList . getDependencies $ dependencies
-
- allSpecs :: Ms.BareSpec -> [(ModName, Ms.BareSpec)]
- allSpecs validSpec = toLegacyTarget validSpec : legacyDependencies
-
- legacyBareSpec :: Spec LocBareType F.LocSymbol
- legacyBareSpec = review bareSpecIso bareSpec
-
--------------------------------------------------------------------------------------
--- | @makeGhcSpec@ invokes @makeGhcSpec0@ to construct the @GhcSpec@ and then
--- validates it using @checkGhcSpec@.
--------------------------------------------------------------------------------------
-makeGhcSpec :: Config
- -> GhcSrc
- -> LogicMap
- -> [(ModName, Ms.BareSpec)]
- -> Either Diagnostics ([Warning], GhcSpec)
--------------------------------------------------------------------------------------
-makeGhcSpec cfg src lmap validatedSpecs = do
- case diagnostics of
- Left e | noErrors e -> pure (allWarnings e, sp)
- Left e -> Left e
- Right () -> pure (mempty, sp)
- where
- diagnostics = Bare.checkTargetSpec (map snd validatedSpecs)
- (view targetSrcIso src)
- renv
- cbs
- (fst . view targetSpecGetter $ sp)
- sp = makeGhcSpec0 cfg src lmap validatedSpecs
- renv = ghcSpecEnv sp
- cbs = _giCbs src
-
-ghcSpecEnv :: GhcSpec -> SEnv SortedReft
-ghcSpecEnv sp = fromListSEnv binds
- where
- emb = gsTcEmbeds (_gsName sp)
- binds = concat
- [ [(x, rSort t) | (x, Loc _ _ t) <- gsMeas (_gsData sp)]
- , [(symbol v, rSort t) | (v, Loc _ _ t) <- gsCtors (_gsData sp)]
- , [(symbol v, vSort v) | v <- gsReflects (_gsRefl sp)]
- , [(x, vSort v) | (x, v) <- gsFreeSyms (_gsName sp), Ghc.isConLikeId v ]
- , [(x, RR s mempty) | (x, s) <- wiredSortedSyms ]
- , [(x, RR s mempty) | (x, s) <- _gsImps sp ]
- ]
- vSort = Bare.varSortedReft emb
- rSort = rTypeSortedReft emb
-
-
--------------------------------------------------------------------------------------
--- | @makeGhcSpec0@ slurps up all the relevant information needed to generate
--- constraints for a target module and packages them into a @GhcSpec@
--- See [NOTE] LIFTING-STAGES to see why we split into lSpec0, lSpec1, etc.
--- 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 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 = finalLiftedSpec
- { impSigs = makeImports mspecs
- , expSigs = [ (F.symbol v, F.sr_sort $ Bare.varSortedReft embs v) | v <- gsReflects refl ]
- , dataDecls = dataDecls mySpec2
- , measures = Ms.measures mySpec
- -- We want to export measures in a 'LiftedSpec', especially if they are
- -- required to check termination of some 'liftedSigs' we export. Due to the fact
- -- that 'lSpec1' doesn't contain the measures that we compute via 'makeHaskellMeasures',
- -- we take them from 'mySpec', which has those.
- , asmSigs = Ms.asmSigs finalLiftedSpec ++ Ms.asmSigs mySpec
- -- Export all the assumptions (not just the ones created out of reflection) in
- -- a 'LiftedSpec'.
- , imeasures = Ms.imeasures finalLiftedSpec ++ Ms.imeasures mySpec
- -- Preserve user-defined 'imeasures'.
- , dvariance = Ms.dvariance finalLiftedSpec ++ Ms.dvariance mySpec
- -- Preserve user-defined 'dvariance'.
- , rinstance = Ms.rinstance finalLiftedSpec ++ Ms.rinstance mySpec
- -- Preserve rinstances.
- }
- }
- where
- finalLiftedSpec = makeLiftedSpec src env refl sData sig qual myRTE lSpec1
- -- build up spec components
- 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
- -- 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
- 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
- mySpec1 = mySpec0 <> lSpec0
- 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
- -- check barespecs
- name = F.notracepp ("ALL-SPECS" ++ zzz) $ _giTargetMod src
- zzz = F.showpp (fst <$> mspecs)
-
-splitSpecs :: ModName -> [(ModName, Ms.BareSpec)] -> (Ms.BareSpec, Bare.ModSpecs)
-splitSpecs name specs = (mySpec, iSpecm)
- where
- mySpec = mconcat (snd <$> mySpecs)
- (mySpecs, iSpecs) = L.partition ((name ==) . fst) specs
- iSpecm = fmap mconcat . Misc.group $ iSpecs
-
-
-makeImports :: [(ModName, Ms.BareSpec)] -> [(F.Symbol, F.Sort)]
-makeImports specs = concatMap (expSigs . snd) specs'
- where specs' = filter (isSrcImport . fst) specs
-
-
-makeEmbeds :: GhcSrc -> Bare.Env -> [(ModName, Ms.BareSpec)] -> F.TCEmb Ghc.TyCon
-makeEmbeds src env
- = Bare.addClassEmbeds (_gsCls src) (_gsFiTcs src)
- . mconcat
- . map (makeTyConEmbeds env)
-
-makeTyConEmbeds :: Bare.Env -> (ModName, Ms.BareSpec) -> F.TCEmb Ghc.TyCon
-makeTyConEmbeds env (name, spec)
- = F.tceFromList [ (tc, t) | (c,t) <- F.tceToList (Ms.embeds spec), tc <- symTc c ]
- where
- symTc = Mb.maybeToList . Bare.maybeResolveSym env name "embed-tycon"
-
---------------------------------------------------------------------------------
--- | [NOTE]: REFLECT-IMPORTS
---
--- 1. MAKE the full LiftedSpec, which will eventually, contain:
--- makeHaskell{Inlines, Measures, Axioms, Bounds}
--- 2. SAVE the LiftedSpec, which will be reloaded
---
--- This step creates the aliases and inlines etc. It must be done BEFORE
--- we compute the `SpecType` for (all, including the reflected binders),
--- as we need the inlines and aliases to properly `expand` the SpecTypes.
---------------------------------------------------------------------------------
-makeLiftedSpec1 :: Config -> GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec
- -> Ms.BareSpec
-makeLiftedSpec1 _ src tycEnv lmap mySpec = mempty
- { Ms.measures = Bare.makeHaskellMeasures src tycEnv lmap mySpec }
-
---------------------------------------------------------------------------------
--- | [NOTE]: LIFTING-STAGES
---
--- We split the lifting up into stage:
--- 0. Where we only lift inlines,
--- 1. Where we lift reflects, measures, and normalized tySigs
---
--- This is because we need the inlines to build the @BareRTEnv@ which then
--- does the alias @expand@ business, that in turn, lets us build the DataConP,
--- i.e. the refined datatypes and their associate selectors, projectors etc,
--- that are needed for subsequent stages of the lifting.
---------------------------------------------------------------------------------
-makeLiftedSpec0 :: Config -> GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec
- -> Ms.BareSpec
-makeLiftedSpec0 cfg src embs lmap mySpec = mempty
- { Ms.ealiases = lmapEAlias . snd <$> Bare.makeHaskellInlines src embs lmap mySpec
- , Ms.reflects = Ms.reflects mySpec
- , Ms.dataDecls = Bare.makeHaskellDataDecls cfg name mySpec tcs
- , Ms.embeds = Ms.embeds mySpec
- -- We do want 'embeds' to survive and to be present into the final 'LiftedSpec'. The
- -- caveat is to decide which format is more appropriate. We obviously cannot store
- -- them as a 'TCEmb TyCon' as serialising a 'TyCon' would be fairly exponsive. This
- -- needs more thinking.
- , Ms.cmeasures = Ms.cmeasures mySpec
- -- We do want 'cmeasures' to survive and to be present into the final 'LiftedSpec'. The
- -- caveat is to decide which format is more appropriate. This needs more thinking.
- }
- where
- tcs = uniqNub (_gsTcs src ++ refTcs)
- refTcs = reflectedTyCons cfg embs cbs mySpec
- cbs = _giCbs src
- name = _giTargetMod src
-
-uniqNub :: (Ghc.Uniquable a) => [a] -> [a]
-uniqNub xs = M.elems $ M.fromList [ (index x, x) | x <- xs ]
- where
- index = Ghc.getKey . Ghc.getUnique
-
--- | 'reflectedTyCons' returns the list of `[TyCon]` that must be reflected but
--- which are defined *outside* the current module e.g. in Base or somewhere
--- that we don't have access to the code.
-
-reflectedTyCons :: Config -> TCEmb Ghc.TyCon -> [Ghc.CoreBind] -> Ms.BareSpec -> [Ghc.TyCon]
-reflectedTyCons cfg embs cbs spec
- | exactDCFlag cfg = filter (not . isEmbedded embs)
- $ concatMap varTyCons
- $ reflectedVars spec cbs
- | otherwise = []
-
--- | We cannot reflect embedded tycons (e.g. Bool) as that gives you a sort
--- conflict: e.g. what is the type of is-True? does it take a GHC.Types.Bool
--- or its embedding, a bool?
-isEmbedded :: TCEmb Ghc.TyCon -> Ghc.TyCon -> Bool
-isEmbedded embs c = F.tceMember c embs
-
-varTyCons :: Ghc.Var -> [Ghc.TyCon]
-varTyCons = specTypeCons . ofType . Ghc.varType
-
-specTypeCons :: SpecType -> [Ghc.TyCon]
-specTypeCons = foldRType tc []
- where
- tc acc t@(RApp {}) = (rtc_tc $ rt_tycon t) : acc
- tc acc _ = acc
-
-reflectedVars :: Ms.BareSpec -> [Ghc.CoreBind] -> [Ghc.Var]
-reflectedVars spec cbs = (fst <$> xDefs)
- where
- xDefs = Mb.mapMaybe (`GM.findVarDef` cbs) reflSyms
- reflSyms = fmap val . S.toList . Ms.reflects $ spec
-
-------------------------------------------------------------------------------------------
-makeSpecVars :: Config -> GhcSrc -> Ms.BareSpec -> Bare.Env -> Bare.MeasEnv -> GhcSpecVars
-------------------------------------------------------------------------------------------
-makeSpecVars cfg src mySpec env measEnv = SpVar
- { gsTgtVars = map (resolveStringVar env name) (checks cfg)
- , gsIgnoreVars = S.map (Bare.lookupGhcVar env name "gs-ignores") (Ms.ignores mySpec)
- , gsLvars = S.map (Bare.lookupGhcVar env name "gs-lvars" ) (Ms.lvars mySpec)
- , gsCMethods = snd3 <$> Bare.meMethods measEnv
- }
- where name = _giTargetMod src
-
-qualifySymbolic :: (F.Symbolic a) => ModName -> a -> F.Symbol
-qualifySymbolic name s = GM.qualifySymbol (F.symbol name) (F.symbol s)
-
-resolveStringVar :: Bare.Env -> ModName -> String -> Ghc.Var
-resolveStringVar env name s = Bare.lookupGhcVar env name "resolve-string-var" lx
- where
- lx = dummyLoc (qualifySymbolic name s)
-
-------------------------------------------------------------------------------------------
-makeSpecQual :: Config -> Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> BareRTEnv -> Bare.ModSpecs
- -> GhcSpecQual
-------------------------------------------------------------------------------------------
-makeSpecQual _cfg env tycEnv measEnv _rtEnv specs = SpQual
- { gsQualifiers = filter okQual quals
- , gsRTAliases = [] -- makeSpecRTAliases env rtEnv -- TODO-REBARE
- }
- where
- quals = concatMap (makeQualifiers env tycEnv) (M.toList specs)
- -- mSyms = F.tracepp "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
- $ (fst <$> wiredSortedSyms)
- ++ (fst <$> Bare.meSyms measEnv)
- ++ (fst <$> Bare.meClassSyms measEnv)
-
-makeQualifiers :: Bare.Env -> Bare.TycEnv -> (ModName, Ms.Spec ty bndr) -> [F.Qualifier]
-makeQualifiers env tycEnv (mod, spec)
- = fmap (Bare.qualifyTopDummy env mod)
- . Mb.mapMaybe (resolveQParams env tycEnv mod)
- $ Ms.qualifiers spec
-
-
--- | @resolveQualParams@ converts the sorts of parameters from, e.g.
--- 'Int' ===> 'GHC.Types.Int' or
--- 'Ptr' ===> 'GHC.Ptr.Ptr'
--- It would not be required if _all_ qualifiers are scraped from
--- function specs, but we're keeping it around for backwards compatibility.
-
-resolveQParams :: Bare.Env -> Bare.TycEnv -> ModName -> F.Qualifier -> Maybe F.Qualifier
-resolveQParams env tycEnv name q = do
- qps <- mapM goQP (F.qParams q)
- return $ q { F.qParams = qps }
- where
- goQP qp = do { s <- go (F.qpSort qp) ; return qp { F.qpSort = s } }
- go :: F.Sort -> Maybe F.Sort
- go (FAbs i s) = FAbs i <$> go s
- go (FFunc s1 s2) = FFunc <$> go s1 <*> go s2
- go (FApp s1 s2) = FApp <$> go s1 <*> go s2
- go (FTC c) = qualifyFTycon env tycEnv name c
- go s = Just s
-
-qualifyFTycon :: Bare.Env -> Bare.TycEnv -> ModName -> F.FTycon -> Maybe F.Sort
-qualifyFTycon env tycEnv name c
- | isPrimFTC = Just (FTC c)
- | otherwise = tyConSort embs . F.atLoc tcs <$> ty
- where
- ty = Bare.maybeResolveSym env name "qualify-FTycon" tcs
- isPrimFTC = (F.val tcs) `elem` F.prims
- tcs = F.fTyconSymbol c
- embs = Bare.tcEmbs tycEnv
-
-tyConSort :: F.TCEmb Ghc.TyCon -> F.Located Ghc.TyCon -> F.Sort
-tyConSort embs lc = Mb.maybe s0 fst (F.tceLookup c embs)
- where
- c = F.val lc
- s0 = tyConSortRaw lc
-
-tyConSortRaw :: F.Located Ghc.TyCon -> F.Sort
-tyConSortRaw = FTC . F.symbolFTycon . fmap F.symbol
-
-------------------------------------------------------------------------------------------
-makeSpecTerm :: Config -> Ms.BareSpec -> Bare.Env -> ModName -> GhcSpecTerm
-------------------------------------------------------------------------------------------
-makeSpecTerm cfg mySpec env name = SpTerm
- { gsLazy = S.insert dictionaryVar (lazies `mappend` sizes)
- , gsFail = makeFail env name mySpec
- , gsStTerm = sizes
- , gsAutosize = autos
- , gsDecr = makeDecrs env name mySpec
- , gsNonStTerm = mempty
- }
- where
- lazies = makeLazy env name mySpec
- autos = makeAutoSize env name mySpec
- strT = not (structuralTerm cfg)
- sizes
- | strT = makeSize env name mySpec
- | otherwise = mempty
-
--- formerly, makeHints
-makeDecrs :: Bare.Env -> ModName -> Ms.BareSpec -> [(Ghc.Var, [Int])]
-makeDecrs env name mySpec =
- [ (v, z) | (lx, z) <- Ms.decr mySpec
- , let v = Bare.lookupGhcVar env name "decreasing" lx
- ]
-
-makeLazy :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet Ghc.Var
-makeLazy env name spec =
- S.map (Bare.lookupGhcVar env name "Var") (Ms.lazy spec)
-
-makeFail :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet (Located Ghc.Var)
-makeFail env name spec =
- S.map (\x -> x{ val = Bare.lookupGhcVar env name "Var" x}) (Ms.fails spec)
-
-makeRewrite :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet (Located Ghc.Var)
-makeRewrite env name spec =
- S.map (\x -> x{ val = Bare.lookupGhcVar env name "Var" x}) (Ms.rewrites spec)
-
-makeRewriteWith :: Bare.Env -> ModName -> Ms.BareSpec -> M.HashMap Ghc.Var [Ghc.Var]
-makeRewriteWith env name spec =
- M.fromList [ (lu x, lu <$> xs) | (x,xs) <- M.toList $ Ms.rewriteWith spec]
- where lu = Bare.lookupGhcVar env name "Var"
-
-
-makeAutoSize :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet Ghc.TyCon
-makeAutoSize env name spec =
- S.map (Bare.lookupGhcTyCon env name "TyCon") (Ms.autosize spec)
-
-makeSize :: Bare.Env -> ModName -> Ms.BareSpec -> S.HashSet Ghc.Var
-makeSize env name spec =
- S.map (Bare.lookupGhcVar env name "Var") (S.fromList lzs)
- where
- lzs = Mb.catMaybes (getSizeFuns <$> Ms.dataDecls spec)
- getSizeFuns decl
- | Just x <- tycSFun decl
- , SymSizeFun f <- x
- = Just f
- | otherwise
- = Nothing
-
-------------------------------------------------------------------------------------------
-makeSpecLaws :: Bare.Env -> Bare.SigEnv -> [(Ghc.Var,LocSpecType)] -> Bare.MeasEnv -> Bare.ModSpecs
- -> GhcSpecLaws
-------------------------------------------------------------------------------------------
-makeSpecLaws env sigEnv sigs menv specs = SpLaws
- { gsLawDefs = second (map (\(_,x,y) -> (x,y))) <$> Bare.meCLaws menv
- , gsLawInst = Bare.makeInstanceLaws env sigEnv sigs specs
- }
-
-------------------------------------------------------------------------------------------
-makeSpecRefl :: Config -> GhcSrc -> Bare.MeasEnv -> Bare.ModSpecs -> Bare.Env -> ModName -> GhcSpecSig -> Bare.TycEnv
- -> GhcSpecRefl
-------------------------------------------------------------------------------------------
-makeSpecRefl cfg src menv specs env name sig tycEnv = SpRefl
- { gsLogicMap = lmap
- , gsAutoInst = 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)
- , gsHAxioms = F.notracepp "gsHAxioms" xtes
- , gsWiredReft = wReflects
- , gsRewrites = makeRewrite env name mySpec
- , gsRewritesWith = makeRewriteWith env name mySpec
- }
- where
- wReflects = Bare.wiredReflects cfg env name sig
- lawMethods = F.notracepp "Law Methods" $ concatMap Ghc.classMethods (fst <$> Bare.meCLaws menv)
- mySpec = M.lookupDefault mempty name specs
- xtes = Bare.makeHaskellAxioms cfg src env tycEnv name lmap sig mySpec
- myAxioms = [ Bare.qualifyTop env name (F.loc lt) (e {eqName = symbol x}) | (x, lt, e) <- xtes]
- rflSyms = S.fromList (getReflects specs)
- sigVars = F.notracepp "SIGVARS" $ (fst3 <$> xtes) -- reflects
- ++ (fst <$> gsAsmSigs sig) -- assumes
- ++ (fst <$> gsRefSigs sig)
- -- ++ (fst <$> gsTySigs sig) -- measures
-
- lmap = Bare.reLMap env
-
-isReflectVar :: S.HashSet F.Symbol -> Ghc.Var -> Bool
-isReflectVar reflSyms v = S.member vx reflSyms
- where
- vx = GM.dropModuleNames (symbol v)
-
-getReflects :: Bare.ModSpecs -> [Symbol]
-getReflects = fmap val . S.toList . S.unions . fmap (names . snd) . M.toList
- where
- names z = S.unions [ Ms.reflects z, Ms.inlines z, Ms.hmeas z ]
-
-------------------------------------------------------------------------------------------
--- | @updateReflSpecSig@ uses the information about reflected functions to update the
--- "assumed" signatures.
-------------------------------------------------------------------------------------------
-addReflSigs :: GhcSpecRefl -> GhcSpecSig -> GhcSpecSig
-------------------------------------------------------------------------------------------
-addReflSigs refl sig = sig { gsRefSigs = reflSigs, gsAsmSigs = wreflSigs ++ filter notReflected (gsAsmSigs sig) }
- where
- (wreflSigs, reflSigs) = L.partition ((`elem` gsWiredReft refl) . fst)
- [ (x, t) | (x, t, _) <- gsHAxioms refl ]
- reflected = fst <$> (wreflSigs ++ reflSigs)
- notReflected xt = fst xt `notElem` reflected
-
-makeAutoInst :: Bare.Env -> ModName -> Ms.BareSpec -> M.HashMap Ghc.Var (Maybe Int)
-makeAutoInst env name spec = Misc.hashMapMapKeys (Bare.lookupGhcVar env name "Var") (Ms.autois spec)
-
-----------------------------------------------------------------------------------------
-makeSpecSig :: Config -> ModName -> Bare.ModSpecs -> Bare.Env -> Bare.SigEnv -> Bare.TycEnv -> Bare.MeasEnv -> [Ghc.CoreBind]
- -> GhcSpecSig
-----------------------------------------------------------------------------------------
-makeSpecSig cfg name specs env sigEnv tycEnv measEnv cbs = SpSig
- { gsTySigs = F.notracepp "gsTySigs" tySigs
- , gsAsmSigs = F.notracepp "gsAsmSigs" asmSigs
- , gsRefSigs = []
- , gsDicts = dicts
- , gsMethods = if noclasscheck cfg then [] else Bare.makeMethodTypes dicts (Bare.meClasses measEnv) cbs
- , gsInSigs = mempty -- TODO-REBARE :: ![(Var, LocSpecType)]
- , gsNewTypes = makeNewTypes env sigEnv allSpecs
- , gsTexprs = [ (v, t, es) | (v, t, Just es) <- mySigs ]
- }
- where
- dicts = Bare.makeSpecDictionaries env sigEnv specs
- mySpec = M.lookupDefault mempty name specs
- asmSigs = Bare.tcSelVars tycEnv
- ++ makeAsmSigs env sigEnv name specs
- ++ [ (x,t) | (_, x, t) <- concat $ map snd (Bare.meCLaws measEnv)]
- tySigs = strengthenSigs . concat $
- [ [(v, (0, t)) | (v, t,_) <- mySigs ] -- NOTE: these weights are to priortize
- , [(v, (1, t)) | (v, t ) <- makeMthSigs measEnv ] -- user defined sigs OVER auto-generated
- , [(v, (2, t)) | (v, t ) <- makeInlSigs env rtEnv allSpecs ] -- during the strengthening, i.e. to KEEP
- , [(v, (3, t)) | (v, t ) <- makeMsrSigs env rtEnv allSpecs ] -- the binders used in USER-defined sigs
- ] -- as they appear in termination metrics
- mySigs = F.notracepp "MAKE-TYSIGS" $ makeTySigs env sigEnv name mySpec
- allSpecs = M.toList specs
- rtEnv = Bare.sigRTEnv sigEnv
- -- hmeas = makeHMeas env allSpecs
-
-strengthenSigs :: [(Ghc.Var, (Int, LocSpecType))] ->[(Ghc.Var, LocSpecType)]
-strengthenSigs sigs = go <$> Misc.groupList sigs
- where
- go (v, ixs) = (v,) $ L.foldl1' (flip meetLoc) (F.notracepp ("STRENGTHEN-SIGS: " ++ F.showpp v) (prio ixs))
- prio = fmap snd . Misc.sortOn fst
- meetLoc :: LocSpecType -> LocSpecType -> LocSpecType
- meetLoc t1 t2 = t1 {val = val t1 `F.meet` val t2}
-
-makeMthSigs :: Bare.MeasEnv -> [(Ghc.Var, LocSpecType)]
-makeMthSigs measEnv = [ (v, t) | (_, v, t) <- Bare.meMethods measEnv ]
-
-makeInlSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]
-makeInlSigs env rtEnv
- = makeLiftedSigs rtEnv CoreToLogic.inlineSpecType
- . makeFromSet "hinlines" Ms.inlines env
-
-makeMsrSigs :: Bare.Env -> BareRTEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.Var, LocSpecType)]
-makeMsrSigs env rtEnv
- = makeLiftedSigs rtEnv CoreToLogic.measureSpecType
- . makeFromSet "hmeas" Ms.hmeas env
-
-makeLiftedSigs :: BareRTEnv -> (Ghc.Var -> SpecType) -> [Ghc.Var] -> [(Ghc.Var, LocSpecType)]
-makeLiftedSigs rtEnv f xs
- = [(x, lt) | x <- xs
- , let lx = GM.locNamedThing x
- , let lt = expand $ lx {val = f x}
- ]
- where
- expand = Bare.specExpandType rtEnv
-
-makeFromSet :: String -> (Ms.BareSpec -> S.HashSet LocSymbol) -> Bare.Env -> [(ModName, Ms.BareSpec)]
- -> [Ghc.Var]
-makeFromSet msg f env specs = concat [ mk n xs | (n, s) <- specs, let xs = S.toList (f s)]
- where
- mk name = Mb.mapMaybe (Bare.maybeResolveSym env name msg)
-
-makeTySigs :: Bare.Env -> Bare.SigEnv -> ModName -> Ms.BareSpec
- -> [(Ghc.Var, LocSpecType, Maybe [Located F.Expr])]
-makeTySigs env sigEnv name spec
- = [ (x, cook x bt, z) | (x, bt, z) <- rawSigs ]
- where
- rawSigs = Bare.resolveLocalBinds env expSigs
- expSigs = makeTExpr env name bareSigs rtEnv spec
- bareSigs = bareTySigs env name spec
- rtEnv = Bare.sigRTEnv sigEnv
- cook x bt = Bare.cookSpecType env sigEnv name (Bare.HsTV x) bt
-
-bareTySigs :: Bare.Env -> ModName -> Ms.BareSpec -> [(Ghc.Var, LocBareType)]
-bareTySigs env name spec = checkDuplicateSigs
- [ (v, t) | (x, t) <- Ms.sigs spec ++ Ms.localSigs spec
- , let v = F.notracepp "LOOKUP-GHC-VAR" $ Bare.lookupGhcVar env name "rawTySigs" x
- ]
-
--- checkDuplicateSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)]
-checkDuplicateSigs :: (Symbolic x) => [(x, F.Located t)] -> [(x, F.Located t)]
-checkDuplicateSigs xts = case Misc.uniqueByKey symXs of
- Left (k, ls) -> uError (errDupSpecs (pprint k) (GM.sourcePosSrcSpan <$> ls))
- Right _ -> xts
- where
- symXs = [ (F.symbol x, F.loc t) | (x, t) <- xts ]
-
-
-makeAsmSigs :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs -> [(Ghc.Var, LocSpecType)]
-makeAsmSigs env sigEnv myName specs =
- [ (x, t) | (name, x, bt) <- rawAsmSigs env myName specs
- , let t = Bare.cookSpecType env sigEnv name (Bare.LqTV x) bt
- ]
-
-rawAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs -> [(ModName, Ghc.Var, LocBareType)]
-rawAsmSigs env myName specs =
- [ (m, v, t) | (v, sigs) <- allAsmSigs env myName specs
- , let (m, t) = myAsmSig v sigs
- ]
-
-myAsmSig :: Ghc.Var -> [(Bool, ModName, LocBareType)] -> (ModName, LocBareType)
-myAsmSig v sigs = Mb.fromMaybe errImp (Misc.firstMaybes [mbHome, mbImp])
- where
- mbHome = takeUnique err sigsHome
- mbImp = takeUnique err (Misc.firstGroup sigsImp) -- see [NOTE:Prioritize-Home-Spec]
- sigsHome = [(m, t) | (True, m, t) <- sigs ]
- sigsImp = F.notracepp ("SIGS-IMP: " ++ F.showpp v)
- [(d, (m, t)) | (False, m, t) <- sigs, let d = nameDistance vName m]
- err ts = ErrDupSpecs (Ghc.getSrcSpan v) (F.pprint v) (GM.sourcePosSrcSpan . F.loc . snd <$> ts) :: UserError
- errImp = impossible Nothing "myAsmSig: cannot happen as sigs is non-null"
- vName = GM.takeModuleNames (F.symbol v)
-
-makeTExpr :: Bare.Env -> ModName -> [(Ghc.Var, LocBareType)] -> BareRTEnv -> Ms.BareSpec
- -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]
-makeTExpr env name tySigs rtEnv spec
- = F.notracepp "MAKE-TEXPRS"
- [ (v, t, qual t <$> es) | (v, (t, es)) <- M.toList vSigExprs ]
- where
- qual t es = qualifyTermExpr env name rtEnv t <$> es
- vSigExprs = Misc.hashMapMapWithKey (\v t -> (t, M.lookup v vExprs)) vSigs
- vExprs = M.fromList (makeVarTExprs env name spec)
- vSigs = M.fromList tySigs
-
-qualifyTermExpr :: Bare.Env -> ModName -> BareRTEnv -> LocBareType -> Located F.Expr
- -> Located F.Expr
-qualifyTermExpr env name rtEnv t le
- = F.atLoc le (Bare.qualifyExpand env name rtEnv l bs e)
- where
- l = F.loc le
- e = F.val le
- bs = ty_binds . toRTypeRep . val $ t
-
-makeVarTExprs :: Bare.Env -> ModName -> Ms.BareSpec -> [(Ghc.Var, [Located F.Expr])]
-makeVarTExprs env name spec =
- [ (Bare.lookupGhcVar env name "Var" x, es)
- | (x, es) <- Ms.termexprs spec ]
-----------------------------------------------------------------------------------------
--- [NOTE:Prioritize-Home-Spec] Prioritize spec for THING defined in
--- `Foo.Bar.Baz.Quux.x` over any other specification, IF GHC's
--- fully qualified name for THING is `Foo.Bar.Baz.Quux.x`.
---
--- For example, see tests/names/neg/T1078.hs for example,
--- which assumes a spec for `head` defined in both
---
--- (1) Data/ByteString.spec
--- (2) Data/ByteString/Char8.spec
---
--- We end up resolving the `head` in (1) to the @Var@ `Data.ByteString.Char8.head`
--- even though there is no exact match, just to account for re-exports of "internal"
--- modules and such (see `Resolve.matchMod`). However, we should pick the closer name
--- if its available.
-----------------------------------------------------------------------------------------
-nameDistance :: F.Symbol -> ModName -> Int
-nameDistance vName tName
- | vName == F.symbol tName = 0
- | otherwise = 1
-
-
-takeUnique :: Ex.Exception e => ([a] -> e) -> [a] -> Maybe a
-takeUnique _ [] = Nothing
-takeUnique _ [x] = Just x
-takeUnique f xs = Ex.throw (f xs)
-
-allAsmSigs :: Bare.Env -> ModName -> Bare.ModSpecs -> [(Ghc.Var, [(Bool, ModName, LocBareType)])]
-allAsmSigs env myName specs = Misc.groupList
- [ (v, (must, name, t))
- | (name, spec) <- M.toList specs
- , (must, x, t) <- getAsmSigs myName name spec
- , v <- Mb.maybeToList (resolveAsmVar env name must x)
- ]
-
-resolveAsmVar :: Bare.Env -> ModName -> Bool -> LocSymbol -> Maybe Ghc.Var
-resolveAsmVar env name True lx = Just $ Bare.lookupGhcVar env name "resolveAsmVar-True" lx
-resolveAsmVar env name False lx = Bare.maybeResolveSym env name "resolveAsmVar-False" lx
-
-getAsmSigs :: ModName -> ModName -> Ms.BareSpec -> [(Bool, LocSymbol, LocBareType)]
-getAsmSigs myName name spec
- | myName == name = [ (True, x, t) | (x, t) <- Ms.asmSigs spec ] -- MUST resolve, or error
- | otherwise = [ (False, x', t) | (x, t) <- Ms.asmSigs spec
- ++ Ms.sigs spec
- , let x' = qSym x ] -- MAY-NOT resolve
- where
- qSym = fmap (GM.qualifySymbol ns)
- ns = F.symbol name
-
--- TODO-REBARE: grepClassAssumes
-_grepClassAssumes :: [RInstance t] -> [(Located F.Symbol, t)]
-_grepClassAssumes = concatMap go
- where
- go xts = Mb.mapMaybe goOne (risigs xts)
- goOne (x, RIAssumed t) = Just (fmap (F.symbol . (".$c" ++ ) . F.symbolString) x, t)
- goOne (_, RISig _) = Nothing
-
-makeSigEnv :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> S.HashSet StableName -> BareRTEnv -> Bare.SigEnv
-makeSigEnv embs tyi exports rtEnv = Bare.SigEnv
- { sigEmbs = embs
- , sigTyRTyMap = tyi
- , sigExports = exports
- , sigRTEnv = rtEnv
- }
-
-makeNewTypes :: Bare.Env -> Bare.SigEnv -> [(ModName, Ms.BareSpec)] -> [(Ghc.TyCon, LocSpecType)]
-makeNewTypes env sigEnv specs =
- [ ct | (name, spec) <- specs
- , d <- Ms.newtyDecls spec
- , ct <- makeNewType env sigEnv name d
- ]
-
-makeNewType :: Bare.Env -> Bare.SigEnv -> ModName -> DataDecl -> [(Ghc.TyCon, LocSpecType)]
-makeNewType env sigEnv name d
- | Just tc <- tcMb = [(tc, t)]
- | otherwise = []
- where
- tcMb = Bare.lookupGhcDnTyCon env name "makeNewType" tcName
- tcName = tycName d
- t = Bare.cookSpecType env sigEnv name Bare.GenTV bt
- bt = getTy tcName (tycSrcPos d) (tycDCons d)
- getTy _ l [c]
- | [(_, t)] <- dcFields c = Loc l l t
- getTy n l _ = Ex.throw (err n l)
- err n l = ErrOther (GM.sourcePosSrcSpan l) ("Bad new type declaration:" <+> F.pprint n) :: UserError
-
-------------------------------------------------------------------------------------------
-makeSpecData :: GhcSrc -> Bare.Env -> Bare.SigEnv -> Bare.MeasEnv -> GhcSpecSig -> Bare.ModSpecs
- -> GhcSpecData
-------------------------------------------------------------------------------------------
-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
- ]
- , gsMeas = [ (F.symbol x, uRType <$> t) | (x, t) <- measVars ]
- , gsMeasures = Bare.qualifyTopDummy env name <$> (ms1 ++ ms2)
- , gsInvariants = Misc.nubHashOn (F.loc . snd) invs
- , gsIaliases = concatMap (makeIAliases env sigEnv) (M.toList specs)
- , gsUnsorted = usI ++ (concatMap msUnSorted $ concatMap measures specs)
- }
- where
- measVars = Bare.meSyms measEnv -- ms'
- ++ Bare.meClassSyms measEnv -- cms'
- ++ Bare.varMeasures env
- measuresSp = Bare.meMeasureSpec measEnv
- ms1 = M.elems (Ms.measMap measuresSp)
- ms2 = Ms.imeas measuresSp
- mySpec = M.lookupDefault mempty name specs
- name = _giTargetMod src
- (minvs,usI) = makeMeasureInvariants env name sig mySpec
- invs = minvs ++ concat (makeInvariants env sigEnv <$> M.toList specs)
-
-makeIAliases :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(LocSpecType, LocSpecType)]
-makeIAliases env sigEnv (name, spec)
- = [ z | Right z <- mkIA <$> Ms.ialiases spec ]
- where
- -- mkIA :: (LocBareType, LocBareType) -> Either _ (LocSpecType, LocSpecType)
- mkIA (t1, t2) = (,) <$> mkI t1 <*> mkI t2
- mkI = Bare.cookSpecTypeE env sigEnv name Bare.GenTV
-
-makeInvariants :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec) -> [(Maybe Ghc.Var, Located SpecType)]
-makeInvariants env sigEnv (name, spec) =
- [ (Nothing, t)
- | (_, bt) <- Ms.invariants spec
- , Bare.knownGhcType env name bt
- , let t = Bare.cookSpecType env sigEnv name Bare.GenTV bt
- ]
-
-makeMeasureInvariants :: Bare.Env -> ModName -> GhcSpecSig -> Ms.BareSpec
- -> ([(Maybe Ghc.Var, LocSpecType)], [UnSortedExpr])
-makeMeasureInvariants env name sig mySpec
- = mapSnd Mb.catMaybes $
- unzip (measureTypeToInv env name <$> [(x, (y, ty)) | x <- xs, (y, ty) <- sigs
- , isSymbolOfVar (val x) y ])
- where
- sigs = gsTySigs sig
- xs = S.toList (Ms.hmeas mySpec)
-
-isSymbolOfVar :: Symbol -> Ghc.Var -> Bool
-isSymbolOfVar x v = x == symbol' v
- where
- symbol' :: Ghc.Var -> Symbol
- symbol' = GM.dropModuleNames . symbol . Ghc.getName
-
-measureTypeToInv :: Bare.Env -> ModName -> (LocSymbol, (Ghc.Var, LocSpecType)) -> ((Maybe Ghc.Var, LocSpecType), Maybe UnSortedExpr)
-measureTypeToInv env name (x, (v, t))
- = notracepp "measureTypeToInv" $ ((Just v, t {val = Bare.qualifyTop env name (F.loc x) mtype}), usorted)
- where
- trep = toRTypeRep (val t)
- ts = ty_args trep
- args = ty_binds trep
- res = ty_res trep
- z = last args
- tz = last ts
- usorted = if isSimpleADT tz then Nothing else ((mapFst (:[])) <$> mkReft (dummyLoc $ F.symbol v) z tz res)
- mtype
- | null ts
- = uError $ ErrHMeas (GM.sourcePosSrcSpan $ loc t) (pprint x) "Measure has no arguments!"
- | otherwise
- = mkInvariant x z tz res
- isSimpleADT (RApp _ ts _ _) = all isRVar ts
- isSimpleADT _ = False
-
-mkInvariant :: LocSymbol -> Symbol -> SpecType -> SpecType -> SpecType
-mkInvariant x z t tr = strengthen (top <$> t) (MkUReft reft mempty)
- where
- reft = Mb.maybe mempty Reft mreft
- mreft = mkReft x z t tr
-
-
-mkReft :: LocSymbol -> Symbol -> SpecType -> SpecType -> Maybe (Symbol, Expr)
-mkReft x z _t tr
- | Just q <- stripRTypeBase tr
- = let Reft (v, p) = toReft q
- su = mkSubst [(v, mkEApp x [EVar v])]
- p' = pAnd $ filter (\e -> z `notElem` syms e) $ conjuncts p
- in Just (v, subst su p')
-mkReft _ _ _ _
- = Nothing
-
-
--- REBARE: formerly, makeGhcSpec3
--------------------------------------------------------------------------------------------
-makeSpecName :: Bare.Env -> Bare.TycEnv -> Bare.MeasEnv -> ModName -> GhcSpecNames
--------------------------------------------------------------------------------------------
-makeSpecName env tycEnv measEnv name = SpNames
- { gsFreeSyms = Bare.reSyms env
- , gsDconsP = [ F.atLoc dc (dcpCon dc) | dc <- datacons ++ cls ]
- , gsTconsP = Bare.qualifyTopDummy env name <$> tycons
- -- , gsLits = mempty -- TODO-REBARE, redundant with gsMeas
- , gsTcEmbeds = Bare.tcEmbs tycEnv
- , gsADTs = Bare.tcAdts tycEnv
- , gsTyconEnv = Bare.tcTyConMap tycEnv
- }
- where
- datacons, cls :: [DataConP]
- datacons = Bare.tcDataCons tycEnv
- cls = F.notracepp "meClasses" $ Bare.meClasses measEnv
- tycons = Bare.tcTyCons tycEnv
-
-
--- REBARE: formerly, makeGhcCHOP1
--------------------------------------------------------------------------------------------
-makeTycEnv :: Config -> ModName -> Bare.Env -> TCEmb Ghc.TyCon -> Ms.BareSpec -> Bare.ModSpecs
- -> Bare.TycEnv
--------------------------------------------------------------------------------------------
-makeTycEnv cfg myName env embs mySpec iSpecs = Bare.TycEnv
- { tcTyCons = tycons
- , tcDataCons = val <$> datacons
- , tcSelMeasures = dcSelectors
- , tcSelVars = recSelectors
- , tcTyConMap = tyi
- , tcAdts = adts
- , tcDataConMap = dm
- , tcEmbs = embs
- , tcName = myName
- }
- where
- (tcDds, dcs) = Misc.concatUnzip $ Bare.makeConTypes env <$> specs
- 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 = tcs ++ knownWiredTyCons env myName
- 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
- fiTcs = _gsFiTcs (Bare.reSrc env)
-
-knownWiredDataCons :: Bare.Env -> ModName -> [Located DataConP]
-knownWiredDataCons env name = filter isKnown wiredDataCons
- where
- isKnown = Bare.knownGhcDataCon env name . GM.namedLocSymbol . dcpCon . val
-
-knownWiredTyCons :: Bare.Env -> ModName -> [TyConP]
-knownWiredTyCons env name = filter isKnown wiredTyCons
- where
- isKnown = Bare.knownGhcTyCon env name . GM.namedLocSymbol . tcpCon
-
-
--- REBARE: formerly, makeGhcCHOP2
--------------------------------------------------------------------------------------------
-makeMeasEnv :: Bare.Env -> Bare.TycEnv -> Bare.SigEnv -> Bare.ModSpecs -> Bare.MeasEnv
--------------------------------------------------------------------------------------------
-makeMeasEnv env tycEnv sigEnv specs = 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
- cms = Bare.makeClassMeasureSpec measures
- 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
- embs = Bare.tcEmbs tycEnv
- name = Bare.tcName tycEnv
- dms = Bare.makeDefaultMethods env mts
- (cls, mts) = Bare.makeClasses env sigEnv name specs
- laws = Bare.makeCLaws env sigEnv name specs
-
------------------------------------------------------------------------------------------
--- | @makeLiftedSpec@ is used to generate the BareSpec object that should be serialized
--- so that downstream files that import this target can access the lifted definitions,
--- e.g. for measures, reflected functions etc.
------------------------------------------------------------------------------------------
-makeLiftedSpec :: GhcSrc -> Bare.Env
- -> GhcSpecRefl -> GhcSpecData -> GhcSpecSig -> GhcSpecQual -> BareRTEnv
- -> Ms.BareSpec -> Ms.BareSpec
------------------------------------------------------------------------------------------
-makeLiftedSpec src _env refl sData sig qual myRTE lSpec0 = lSpec0
- { Ms.asmSigs = F.notracepp "LIFTED-ASM-SIGS" $ xbs -- ++ mkSigs (gsAsmSigs sig)
- , Ms.reflSigs = F.notracepp "REFL-SIGS" xbs
- , Ms.sigs = F.notracepp "LIFTED-SIGS" $ mkSigs (gsTySigs sig)
- , Ms.invariants = [ ((varLocSym <$> x), Bare.specToBare <$> t)
- | (x, t) <- gsInvariants sData
- , isLocInFile srcF t
- ]
- , Ms.axeqs = gsMyAxioms refl
- , Ms.aliases = F.notracepp "MY-ALIASES" $ M.elems . typeAliases $ myRTE
- , Ms.ealiases = M.elems . exprAliases $ myRTE
- , Ms.qualifiers = filter (isLocInFile srcF) (gsQualifiers qual)
- }
- where
- mkSigs xts = [ toBare (x, t) | (x, t) <- xts
- , S.member x sigVars && (isExportedVar (view targetSrcIso src) x)
- ]
- toBare (x, t) = (varLocSym x, Bare.specToBare <$> t)
- xbs = toBare <$> reflTySigs
- sigVars = S.difference defVars reflVars
- defVars = S.fromList (_giDefVars src)
- reflTySigs = [(x, t) | (x,t,_) <- gsHAxioms refl, x `notElem` gsWiredReft refl]
- reflVars = S.fromList (fst <$> reflTySigs)
- -- myAliases fld = M.elems . fld $ myRTE
- srcF = _giTarget src
-
--- | Returns 'True' if the input determines a location within the input file. Due to the fact we might have
--- Haskell sources which have \"companion\" specs defined alongside them, we also need to account for this
--- case, by stripping out the extensions and check that the LHS is a Haskell source and the RHS a spec file.
-isLocInFile :: (F.Loc a) => FilePath -> a -> Bool
-isLocInFile f lx = f == lifted || isCompanion
- where
- lifted :: FilePath
- lifted = locFile lx
-
- isCompanion :: Bool
- isCompanion =
- (==) (dropExtension f) (dropExtension lifted)
- && isExtFile Hs f
- && isExtFile Files.Spec lifted
-
-locFile :: (F.Loc a) => a -> FilePath
-locFile = Misc.fst3 . F.sourcePosElts . F.sp_start . F.srcSpan
-
-varLocSym :: Ghc.Var -> LocSymbol
-varLocSym v = F.symbol <$> GM.locNamedThing v
-
--- makeSpecRTAliases :: Bare.Env -> BareRTEnv -> [Located SpecRTAlias]
--- makeSpecRTAliases _env _rtEnv = [] -- TODO-REBARE
-
-
---------------------------------------------------------------------------------
--- | @myRTEnv@ slices out the part of RTEnv that was generated by aliases defined
--- in the _target_ file, "cooks" the aliases (by conversion to SpecType), and
--- then saves them back as BareType.
---------------------------------------------------------------------------------
-myRTEnv :: GhcSrc -> Bare.Env -> Bare.SigEnv -> BareRTEnv -> BareRTEnv
-myRTEnv src env sigEnv rtEnv = mkRTE tAs' eAs
- where
- tAs' = normalizeBareAlias env sigEnv name <$> tAs
- tAs = myAliases typeAliases
- eAs = myAliases exprAliases
- myAliases fld = filter (isLocInFile srcF) . M.elems . fld $ rtEnv
- srcF = _giTarget src
- name = _giTargetMod src
-
-mkRTE :: [Located (RTAlias x a)] -> [Located (RTAlias F.Symbol F.Expr)] -> RTEnv x a
-mkRTE tAs eAs = RTE
- { typeAliases = M.fromList [ (aName a, a) | a <- tAs ]
- , exprAliases = M.fromList [ (aName a, a) | a <- eAs ]
- }
- where aName = rtName . F.val
-
-normalizeBareAlias :: Bare.Env -> Bare.SigEnv -> ModName -> Located BareRTAlias
- -> Located BareRTAlias
-normalizeBareAlias env sigEnv name lx = fixRTA <$> lx
- where
- fixRTA :: BareRTAlias -> BareRTAlias
- fixRTA = mapRTAVars fixArg . fmap fixBody
-
- fixArg :: Symbol -> Symbol
- fixArg = F.symbol . GM.symbolTyVar
-
- fixBody :: BareType -> BareType
- fixBody = Bare.specToBare
- . F.val
- . Bare.cookSpecType env sigEnv name Bare.RawTV
- . F.atLoc lx
-
diff --git a/src/Language/Haskell/Liquid/Bare/Axiom.hs b/src/Language/Haskell/Liquid/Bare/Axiom.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Axiom.hs
+++ /dev/null
@@ -1,258 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-
--- | This module contains the code that DOES reflection; i.e. converts Haskell
--- definitions into refinements.
-
-module Language.Haskell.Liquid.Bare.Axiom ( makeHaskellAxioms, wiredReflects ) where
-
-import Prelude hiding (error)
-import Prelude hiding (mapM)
-import qualified Control.Exception as Ex
-
--- import Control.Monad.Except hiding (forM, mapM)
--- import Control.Monad.State hiding (forM, mapM)
-import qualified Text.PrettyPrint.HughesPJ as PJ -- (text)
-import qualified Data.HashSet as S
-import qualified Data.Maybe as Mb
-import Control.Monad.Trans.State.Lazy (runState, get, put)
-
-import Language.Fixpoint.Misc
-import qualified Language.Haskell.Liquid.Measure as Ms
-import qualified Language.Fixpoint.Types as F
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import Language.Haskell.Liquid.Types.RefType
-import Language.Haskell.Liquid.Transforms.CoreToLogic
-import Language.Haskell.Liquid.GHC.Misc
-import Language.Haskell.Liquid.Types
-
-import Language.Haskell.Liquid.Bare.Resolve as Bare
-import Language.Haskell.Liquid.Bare.Types as Bare
-
-
-import IdInfo
-import BasicTypes
-
------------------------------------------------------------------------------------------------
-makeHaskellAxioms :: Config -> GhcSrc -> Bare.Env -> Bare.TycEnv -> ModName -> LogicMap -> GhcSpecSig -> Ms.BareSpec
- -> [(Ghc.Var, LocSpecType, F.Equation)]
------------------------------------------------------------------------------------------------
-makeHaskellAxioms cfg src env tycEnv name lmap spSig spec
- = fmap (makeAxiom env tycEnv name lmap)
- (wiredDefs cfg env name spSig ++ getReflectDefs src spSig spec)
-
-getReflectDefs :: GhcSrc -> GhcSpecSig -> Ms.BareSpec
- -> [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]
-getReflectDefs src sig spec = findVarDefType cbs sigs <$> xs
- where
- sigs = gsTySigs sig
- xs = S.toList (Ms.reflects spec)
- cbs = _giCbs src
-
-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)
- else Ex.throw $ mkError x ("Lifted functions must be exported; please export " ++ show v)
- Nothing -> Ex.throw $ mkError x "Cannot lift haskell function"
-
---------------------------------------------------------------------------------
-makeAxiom :: Bare.Env -> Bare.TycEnv -> ModName -> LogicMap
- -> (LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)
- -> (Ghc.Var, LocSpecType, F.Equation)
---------------------------------------------------------------------------------
-makeAxiom env tycEnv name lmap (x, mbT, v, def)
- = (v, t, e)
- where
- t = Bare.qualifyTop env name (F.loc t0) t0
- (t0, e) = makeAssumeType embs lmap dm x mbT v def
- embs = Bare.tcEmbs tycEnv
- dm = Bare.tcDataConMap tycEnv
-
-mkError :: LocSymbol -> String -> Error
-mkError x str = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (PJ.text str)
-
-makeAssumeType
- :: F.TCEmb Ghc.TyCon -> LogicMap -> DataConMap -> LocSymbol -> Maybe SpecType
- -> Ghc.Var -> Ghc.CoreExpr
- -> (LocSpecType, F.Equation)
-makeAssumeType tce lmap dm x mbT v def
- = (x {val = aty at `strengthenRes` F.subst su ref}, F.mkEquation (val x) xts (F.subst su le) out)
- where
- t = Mb.fromMaybe (ofType τ) mbT
- τ = Ghc.varType v
- at = axiomType x t
- out = rTypeSort tce $ ares at
- xArgs = (F.EVar . fst) <$> aargs at
- _msg = unwords [showpp x, showpp mbT]
- le = case runToLogicWithBoolBinds bbs tce lmap dm mkErr (coreToLogic def') of
- Right e -> e
- Left e -> panic Nothing (show e)
- ref = F.Reft (F.vv_, F.PAtom F.Eq (F.EVar F.vv_) le)
- mkErr s = ErrHMeas (sourcePosSrcSpan $ loc x) (pprint $ val x) (PJ.text s)
- bbs = filter isBoolBind xs
- (xs, def') = grabBody (Ghc.expandTypeSynonyms τ) $ normalize def
- su = F.mkSubst $ zip (F.symbol <$> xs) xArgs
- ++ zip (simplesymbol <$> xs) xArgs
- xts = [(F.symbol x, rTypeSortExp tce t) | (x, t) <- aargs at]
-
-rTypeSortExp :: F.TCEmb Ghc.TyCon -> SpecType -> F.Sort
-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 { Ghc.ft_arg = tx, Ghc.ft_res = t}) e | Ghc.isClassPred tx
- = grabBody t e
-grabBody (Ghc.FunTy { Ghc.ft_res = t}) (Ghc.Lam x e)
- = (x:xs, e') where (xs, e') = grabBody t e
-grabBody t (Ghc.Tick _ e)
- = grabBody t e
-grabBody t@(Ghc.FunTy {}) e
- = (txs++xs, e')
- where (ts,tr) = splitFun t
- (xs, e') = grabBody tr (foldl Ghc.App e (Ghc.Var <$> txs))
- txs = [ stringVar ("ls" ++ show i) t | (t,i) <- zip ts [1..]]
-grabBody _ e
- = ([], e)
-
-splitFun :: Ghc.Type -> ([Ghc.Type], Ghc.Type)
-splitFun = go []
- where go acc (Ghc.FunTy { Ghc.ft_arg = tx, Ghc.ft_res = t}) = go (tx:acc) t
- go acc t = (reverse acc, t)
-
-
-isBoolBind :: Ghc.Var -> Bool
-isBoolBind v = isBool (ty_res $ toRTypeRep ((ofType $ Ghc.varType v) :: RRType ()))
-
-strengthenRes :: SpecType -> F.Reft -> SpecType
-strengthenRes t r = go t
- where
- go (RAllT a t r) = RAllT a (go t) r
- go (RAllP p t) = RAllP p $ go t
- go (RFun x tx t r) = RFun x tx (go t) r
- go t = t `strengthen` F.ofReft r
-
-class Subable a where
- subst :: (Ghc.Var, Ghc.CoreExpr) -> a -> a
-
-instance Subable Ghc.Var where
- subst (x, ex) z
- | x == z, Ghc.Var y <- ex = y
- | otherwise = z
-
-instance Subable Ghc.CoreExpr where
- subst (x, ex) (Ghc.Var y)
- | x == y = ex
- | otherwise = Ghc.Var y
- subst su (Ghc.App f e)
- = Ghc.App (subst su f) (subst su e)
- subst su (Ghc.Lam x e)
- = Ghc.Lam x (subst su e)
- subst su (Ghc.Case e x t alts)
- = Ghc.Case (subst su e) x t (subst su <$> alts)
- subst su (Ghc.Let (Ghc.Rec xes) e)
- = Ghc.Let (Ghc.Rec (mapSnd (subst su) <$> xes)) (subst su e)
- subst su (Ghc.Let (Ghc.NonRec x ex) e)
- = Ghc.Let (Ghc.NonRec x (subst su ex)) (subst su e)
- subst su (Ghc.Cast e t)
- = Ghc.Cast (subst su e) t
- subst su (Ghc.Tick t e)
- = Ghc.Tick t (subst su e)
- subst _ e
- = e
-
-instance Subable Ghc.CoreAlt where
- subst su (c, xs, e) = (c, xs, subst su e)
-
-data AxiomType = AT { aty :: SpecType, aargs :: [(F.Symbol, SpecType)], ares :: SpecType }
-
--- | Specification for Haskell function
-axiomType :: LocSymbol -> SpecType -> AxiomType
-axiomType s t = AT to (reverse xts) res
- where
- (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) = do
- (i,bs,res) <- get
- let x' = unDummy x i
- put (i+1, (x', tx):bs,res)
- t' <- go t
- return $ RFun x' tx t' r
- go t = do
- (i,bs,_) <- get
- let ys = reverse $ map fst bs
- let t' = strengthen t (singletonApp s ys)
- put (i, bs, Just t')
- return t'
-
-unDummy :: F.Symbol -> Int -> F.Symbol
-unDummy x i
- | x /= F.dummySymbol = x
- | otherwise = F.symbol ("lq" ++ show i)
-
-singletonApp :: F.Symbolic a => LocSymbol -> [a] -> UReft F.Reft
-singletonApp s ys = MkUReft r mempty
- where
- r = F.exprReft (F.mkEApp s (F.eVar <$> ys))
-
-
--------------------------------------------------------------------------------
--- | Hardcode imported reflected functions ------------------------------------
--------------------------------------------------------------------------------
-
-
-wiredReflects :: Config -> Bare.Env -> ModName -> GhcSpecSig
- -> [Ghc.Var]
-wiredReflects cfg env name sigs = [v | (_, _, v, _) <- wiredDefs cfg env name sigs ]
-
-
-wiredDefs :: Config -> Bare.Env -> ModName -> GhcSpecSig
- -> [(LocSymbol, Maybe SpecType, Ghc.Var, Ghc.CoreExpr)]
-wiredDefs cfg env name spSig
- | reflection cfg
- = [ functionCompositionDef ]
- | otherwise
- = []
- where
- functionCompositionDef = (x, fmap F.val $ lookup v (gsTySigs spSig), v, makeCompositionExpression v)
- x = F.dummyLoc functionComposisionSymbol
- v = Bare.lookupGhcVar env name "wiredAxioms" x
-
--------------------------------------------------------------------------------
--- | Expression Definitions of Prelude Functions ------------------------------
--- | NV: Currently Just Hacking Composition -----------------------------
--------------------------------------------------------------------------------
-
-
-makeCompositionExpression :: Ghc.Id -> Ghc.CoreExpr
-makeCompositionExpression x
- = go $ Ghc.varType $ F.notracepp ( -- tracing to find the body of . from the inline spec,
- -- replace F.notrace with F.trace to print
- "\nv = " ++ GM.showPpr x ++
- "\n realIdUnfolding = " ++ GM.showPpr (Ghc.realIdUnfolding x) ++
- "\n maybeUnfoldingTemplate . realIdUnfolding = " ++ GM.showPpr (Ghc.maybeUnfoldingTemplate $ Ghc.realIdUnfolding x ) ++
- "\n inl_src . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (inl_src $ inlinePragInfo $ Ghc.idInfo x) ++
- "\n inl_inline . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (inl_inline $ inlinePragInfo $ Ghc.idInfo x) ++
- "\n inl_sat . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (inl_sat $ inlinePragInfo $ Ghc.idInfo x) ++
- "\n inl_act . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (inl_act $ inlinePragInfo $ Ghc.idInfo x) ++
- "\n inl_rule . inlinePragInfo . Ghc.idInfo = " ++ GM.showPpr (inl_rule $ inlinePragInfo $ Ghc.idInfo x) ++
- "\n inl_rule rule = " ++ GM.showPpr (inl_rule $ inlinePragInfo $ Ghc.idInfo x) ++
- "\n inline spec = " ++ GM.showPpr (inl_inline $ inlinePragInfo $ Ghc.idInfo x)
- ) x
- where
- go (Ghc.ForAllTy a (Ghc.ForAllTy b (Ghc.ForAllTy c (Ghc.FunTy { Ghc.ft_arg = tf, Ghc.ft_res = Ghc.FunTy { Ghc.ft_arg = tg, Ghc.ft_res = tx}}))))
- = let f = stringVar "f" tf
- g = stringVar "g" tg
- x = stringVar "x" tx
- in Ghc.Lam (Ghc.binderVar a) $
- Ghc.Lam (Ghc.binderVar b) $
- Ghc.Lam (Ghc.binderVar c) $
- Ghc.Lam f $ Ghc.Lam g $ Ghc.Lam x $ Ghc.App (Ghc.Var f) (Ghc.App (Ghc.Var g) (Ghc.Var x))
- go _ = error "Axioms.go"
diff --git a/src/Language/Haskell/Liquid/Bare/Check.hs b/src/Language/Haskell/Liquid/Bare/Check.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Check.hs
+++ /dev/null
@@ -1,727 +0,0 @@
-{-# LANGUAGE ParallelListComp #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Language.Haskell.Liquid.Bare.Check
- ( checkTargetSpec
- , checkBareSpec
- ) where
-
-import Language.Haskell.Liquid.Constraint.ToFixpoint
-import Language.Haskell.Liquid.GHC.API as Ghc hiding (Located)
-import Control.Applicative ((<|>))
-import Control.Arrow ((&&&))
-import Data.Maybe
-import Data.Function (on)
-import Text.PrettyPrint.HughesPJ hiding ((<>))
-import qualified Data.List as L
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-import Data.Hashable
-import qualified Language.Fixpoint.Misc as Misc
-import Language.Fixpoint.SortCheck (checkSorted, checkSortedReftFull, checkSortFull)
-import qualified Language.Fixpoint.Types as F
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import Language.Haskell.Liquid.Misc (condNull, snd4)
-import Language.Haskell.Liquid.Types
-import Language.Haskell.Liquid.WiredIn
-import Language.Haskell.Liquid.LawInstances (checkLawInstances)
-
-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
-
-
-----------------------------------------------------------------------------------------------
--- | Checking BareSpec ------------------------------------------------------------------------
-----------------------------------------------------------------------------------------------
-checkBareSpec :: ModName -> Ms.BareSpec -> Either Diagnostics ()
-checkBareSpec _ sp
- | allChecks == emptyDiagnostics = Right ()
- | otherwise = Left allChecks
- where
- allChecks = mconcat [ checkUnique "measure" measures
- , checkUnique "field" fields
- , checkDisjoints [ inlines
- , hmeasures
- , S.fromList measures
- , reflects
- , S.fromList fields
- ]
- ]
- inlines = Ms.inlines sp
- hmeasures = Ms.hmeas sp
- reflects = Ms.reflects sp
- measures = msName <$> Ms.measures sp
- fields = concatMap dataDeclFields (Ms.dataDecls sp)
-
-dataDeclFields :: DataDecl -> [F.LocSymbol]
-dataDeclFields = filter (not . GM.isTmpSymbol . F.val)
- . Misc.hashNubWith val
- . concatMap dataCtorFields
- . tycDCons
-
-dataCtorFields :: DataCtor -> [F.LocSymbol]
-dataCtorFields c
- | isGadt c = []
- | otherwise = F.atLoc c <$> [ f | (f,_) <- dcFields c ]
-
-isGadt :: DataCtor -> Bool
-isGadt = isJust . dcResult
-
-checkUnique :: String -> [F.LocSymbol] -> Diagnostics
-checkUnique _ = mkDiagnostics mempty . checkUnique' F.val GM.fSrcSpan
-
-checkUnique' :: (PPrint a, Eq a, Hashable a)
- => (t -> a) -> (t -> Ghc.SrcSpan) -> [t] -> [Error]
-checkUnique' nameF locF ts = [ErrDupSpecs l (pprint n) ls | (n, ls@(l:_)) <- dups]
--- mkErr <$> dups
- where
- -- mkErr (n, ls@(l:_)) = ErrDupSpecs l (pprint n) ls
- dups = [ z | z@(_, _:_:_) <- Misc.groupList nts ]
- nts = [ (n, l) | t <- ts, let n = nameF t, let l = locF t ]
-
-checkDisjoints :: [S.HashSet F.LocSymbol] -> Diagnostics
-checkDisjoints [] = emptyDiagnostics
-checkDisjoints [_] = emptyDiagnostics
-checkDisjoints (s:ss) = checkDisjoint s (S.unions ss) <> checkDisjoints ss
-
-checkDisjoint :: S.HashSet F.LocSymbol -> S.HashSet F.LocSymbol -> Diagnostics
-checkDisjoint s1 s2 = checkUnique "disjoint" (S.toList s1 ++ S.toList s2)
-
-----------------------------------------------------------------------------------------------
--- | Checking TargetSpec
-----------------------------------------------------------------------------------------------
-
-checkTargetSpec :: [Ms.BareSpec]
- -> TargetSrc
- -> F.SEnv F.SortedReft
- -> [CoreBind]
- -> TargetSpec
- -> Either Diagnostics ()
-checkTargetSpec specs src env cbs sp
- | diagnostics == emptyDiagnostics = Right ()
- | otherwise = Left diagnostics
- where
- diagnostics :: Diagnostics
- diagnostics = foldMap (checkBind allowHO bsc "measure" emb tcEnv env) (gsMeas (gsData sp))
- <> condNull noPrune
- (foldMap (checkBind allowHO bsc "constructor" emb tcEnv env) (txCtors $ gsCtors (gsData sp)))
- <> foldMap (checkBind allowHO bsc "assume" emb tcEnv env) (gsAsmSigs (gsSig sp))
- <> foldMap (checkBind allowHO bsc "reflect" emb tcEnv env) (gsRefSigs (gsSig sp))
- <> checkTySigs allowHO bsc cbs emb tcEnv env (gsSig sp)
- -- ++ mapMaybe (checkTerminationExpr emb env) (gsTexprs (gsSig sp))
- <> foldMap (checkBind allowHO bsc "class method" emb tcEnv env) (clsSigs (gsSig sp))
- <> foldMap (checkInv allowHO bsc emb tcEnv env) (gsInvariants (gsData sp))
- <> checkIAl allowHO bsc emb tcEnv env (gsIaliases (gsData sp))
- <> checkMeasures emb env ms
- <> checkClassMeasures (gsMeasures (gsData sp))
- <> checkClassMethods (gsCls src) (gsCMethods (gsVars sp)) (gsTySigs (gsSig sp))
- <> foldMap checkMismatch sigs
- <> checkDuplicate (gsTySigs (gsSig sp))
- -- TODO-REBARE ++ checkQualifiers env (gsQualifiers (gsQual sp))
- <> checkDuplicate (gsAsmSigs (gsSig sp))
- <> checkDupIntersect (gsTySigs (gsSig sp)) (gsAsmSigs (gsSig sp))
- <> checkRTAliases "Type Alias" env tAliases
- <> checkRTAliases "Pred Alias" env eAliases
- -- ++ _checkDuplicateFieldNames (gsDconsP sp)
- -- NV TODO: allow instances of refined classes to be refined
- -- but make sure that all the specs are checked.
- -- ++ checkRefinedClasses rClasses rInsts
- <> checkSizeFun emb env (gsTconsP (gsName sp))
- <> checkPlugged (catMaybes [ fmap (F.dropSym 2 $ GM.simplesymbol x,) (getMethodType t) | (x, t) <- gsMethods (gsSig sp) ])
- <> checkLawInstances (gsLaws sp)
- <> checkRewrites sp
-
- _rClasses = concatMap (Ms.classes ) specs
- _rInsts = concatMap (Ms.rinstance) specs
- tAliases = concat [Ms.aliases sp | sp <- specs]
- eAliases = concat [Ms.ealiases sp | sp <- specs]
- emb = gsTcEmbeds (gsName sp)
- tcEnv = gsTyconEnv (gsName sp)
- ms = gsMeasures (gsData sp)
- clsSigs sp = [ (v, t) | (v, t) <- gsTySigs sp, isJust (isClassOpId_maybe v) ]
- sigs = gsTySigs (gsSig sp) ++ gsAsmSigs (gsSig sp) ++ gsCtors (gsData sp)
- allowHO = higherOrderFlag sp
- bsc = bscope (getConfig sp)
- noPrune = not (pruneFlag sp)
- txCtors ts = [(v, fmap (fmap (fmap (F.filterUnMatched temps))) t) | (v, t) <- ts]
- temps = F.makeTemplates $ gsUnsorted $ gsData sp
- -- env' = L.foldl' (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms
-
-
-
-
-
-checkPlugged :: PPrint v => [(v, LocSpecType)] -> Diagnostics
-checkPlugged xs = mkDiagnostics mempty (map mkErr (filter (hasHoleTy . val . snd) xs))
- where
- mkErr (x,t) = ErrBadData (GM.sourcePosSrcSpan $ loc t) (pprint x) msg
- msg = "Cannot resolve type hole `_`. Use explicit type instead."
-
-
---------------------------------------------------------------------------------
-checkTySigs :: Bool
- -> BScope
- -> [CoreBind]
- -> F.TCEmb TyCon
- -> Bare.TyConMap
- -> F.SEnv F.SortedReft
- -> GhcSpecSig
- -> Diagnostics
---------------------------------------------------------------------------------
-checkTySigs allowHO bsc cbs emb tcEnv env sig
- = mconcat (map (check env) topTs)
- -- (mapMaybe (checkT env) [ (x, t) | (x, (t, _)) <- topTs])
- -- ++ (mapMaybe (checkE env) [ (x, t, es) | (x, (t, Just es)) <- topTs])
- <> coreVisitor checkVisitor env emptyDiagnostics cbs
- where
- check env = checkSigTExpr allowHO bsc emb tcEnv env
- locTm = M.fromList locTs
- (locTs, topTs) = Bare.partitionLocalBinds vtes
- vtes = [ (x, (t, es)) | (x, t) <- gsTySigs sig, let es = M.lookup x vExprs]
- vExprs = M.fromList [ (x, es) | (x, _, es) <- gsTexprs sig ]
-
- checkVisitor :: CoreVisitor (F.SEnv F.SortedReft) Diagnostics
- checkVisitor = CoreVisitor
- { envF = \env v -> F.insertSEnv (F.symbol v) (vSort v) env
- , bindF = \env acc v -> errs env v <> acc
- , exprF = \_ acc _ -> acc
- }
- vSort = Bare.varSortedReft emb
- errs env v = case M.lookup v locTm of
- Nothing -> emptyDiagnostics
- Just t -> check env (v, t)
-
-checkSigTExpr :: Bool -> BScope -> F.TCEmb TyCon -> Bare.TyConMap -> F.SEnv F.SortedReft
- -> (Var, (LocSpecType, Maybe [Located F.Expr]))
- -> Diagnostics
-checkSigTExpr allowHO bsc emb tcEnv env (x, (t, es)) = mbErr1 <> mbErr2
- where
- mbErr1 = checkBind allowHO bsc empty emb tcEnv env (x, t)
- mbErr2 = maybe emptyDiagnostics (checkTerminationExpr emb env . (x, t,)) es
-
-_checkQualifiers :: F.SEnv F.SortedReft -> [F.Qualifier] -> [Error]
-_checkQualifiers = mapMaybe . checkQualifier
-
-checkQualifier :: F.SEnv F.SortedReft -> F.Qualifier -> Maybe Error
-checkQualifier env q = mkE <$> checkSortFull (F.srcSpan q) γ F.boolSort (F.qBody q)
- where
- γ = L.foldl' (\e (x, s) -> F.insertSEnv x (F.RR s mempty) e) env (F.qualBinds q ++ wiredSortedSyms)
- mkE = ErrBadQual (GM.fSrcSpan q) (pprint $ F.qName q)
-
--- | Used for termination checking. If we have no \"len\" defined /yet/ (for example we are checking
--- 'GHC.Prim') then we want to skip this check.
-checkSizeFun :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [TyConP] -> Diagnostics
-checkSizeFun emb env tys = mkDiagnostics mempty (map mkError (mapMaybe go tys))
- where
- mkError ((f, tcp), msg) = ErrTyCon (GM.sourcePosSrcSpan $ tcpLoc tcp)
- (text "Size function" <+> pprint (f x)
- <+> text "should have type int, but it was "
- <+> pprint (tcpCon tcp)
- <+> text "."
- $+$ msg)
- (pprint (tcpCon tcp))
- go tcp = case tcpSizeFun tcp of
- Nothing -> Nothing
- Just f | isWiredInLenFn f -> Nothing -- Skip the check.
- Just f -> checkWFSize (szFun f) tcp
-
- checkWFSize f tcp = ((f, tcp),) <$> checkSortFull (F.srcSpan tcp) (F.insertSEnv x (mkTySort (tcpCon tcp)) env) F.intSort (f x)
- x = "x" :: F.Symbol
- mkTySort tc = rTypeSortedReft emb (ofType $ TyConApp tc (TyVarTy <$> tyConTyVars tc) :: RRType ())
-
- isWiredInLenFn :: SizeFun -> Bool
- isWiredInLenFn IdSizeFun = False
- isWiredInLenFn (SymSizeFun locSym) = isWiredIn locSym
-
-_checkRefinedClasses :: [RClass LocBareType] -> [RInstance LocBareType] -> [Error]
-_checkRefinedClasses definitions instances
- = mkError <$> duplicates
- where
- duplicates
- = mapMaybe checkCls (rcName <$> definitions)
- checkCls cls
- = case findConflicts cls of
- [] -> Nothing
- conflicts -> Just (cls, conflicts)
- findConflicts cls
- = filter ((== cls) . riclass) instances
- mkError (cls, conflicts)
- = ErrRClass (GM.sourcePosSrcSpan $ loc $ btc_tc cls)
- (pprint cls) (ofConflict <$> conflicts)
- ofConflict
- = GM.sourcePosSrcSpan . loc . btc_tc . riclass &&& pprint . ritype
-
-_checkDuplicateFieldNames :: [(DataCon, DataConP)] -> [Error]
-_checkDuplicateFieldNames = mapMaybe go
- where
- go (d, dts) = checkNoDups (dcpLoc dts) d (fst <$> dcpTyArgs dts)
- checkNoDups l d xs = mkErr l d <$> _firstDuplicate xs
-
- mkErr l d x = ErrBadData (GM.sourcePosSrcSpan l)
- (pprint d)
- (text "Multiple declarations of record selector" <+> pprintSymbol x)
-
-_firstDuplicate :: Ord a => [a] -> Maybe a
-_firstDuplicate = go . L.sort
- where
- go (y:x:xs) | x == y = Just x
- | otherwise = go (x:xs)
- go _ = Nothing
-
-checkInv :: Bool
- -> BScope
- -> F.TCEmb TyCon
- -> Bare.TyConMap
- -> F.SEnv F.SortedReft
- -> (Maybe Var, LocSpecType)
- -> Diagnostics
-checkInv allowHO bsc emb tcEnv env (_, t) = checkTy allowHO bsc err emb tcEnv env t
- where
- err = ErrInvt (GM.sourcePosSrcSpan $ loc t) (val t)
-
-checkIAl :: Bool
- -> BScope
- -> F.TCEmb TyCon
- -> Bare.TyConMap
- -> F.SEnv F.SortedReft
- -> [(LocSpecType, LocSpecType)]
- -> Diagnostics
-checkIAl allowHO bsc emb tcEnv env = mconcat . map (checkIAlOne allowHO bsc emb tcEnv env)
-
-checkIAlOne :: Bool
- -> BScope
- -> F.TCEmb TyCon
- -> Bare.TyConMap
- -> F.SEnv F.SortedReft
- -> (LocSpecType, LocSpecType)
- -> Diagnostics
-checkIAlOne allowHO bsc emb tcEnv env (t1, t2) = mconcat $ checkEq : (tcheck <$> [t1, t2])
- where
- tcheck t = checkTy allowHO bsc (err t) emb tcEnv env t
- err t = ErrIAl (GM.sourcePosSrcSpan $ loc t) (val t)
- t1' :: RSort
- t1' = toRSort $ val t1
- t2' :: RSort
- t2' = toRSort $ val t2
- checkEq = if t1' == t2' then emptyDiagnostics else mkDiagnostics mempty [errmis]
- errmis = ErrIAlMis (GM.sourcePosSrcSpan $ loc t1) (val t1) (val t2) emsg
- emsg = pprint t1 <+> text "does not match with" <+> pprint t2
-
-
--- FIXME: Should _ be removed if it isn't used?
-checkRTAliases :: String -> t -> [Located (RTAlias s a)] -> Diagnostics
-checkRTAliases msg _ as = err1s
- where
- err1s = checkDuplicateRTAlias msg as
-
-checkBind :: (PPrint v)
- => Bool
- -> BScope
- -> Doc
- -> F.TCEmb TyCon
- -> Bare.TyConMap
- -> F.SEnv F.SortedReft
- -> (v, LocSpecType)
- -> Diagnostics
-checkBind allowHO bsc s emb tcEnv env (v, t) = checkTy allowHO bsc msg emb tcEnv env t
- where
- msg = ErrTySpec (GM.fSrcSpan t) (Just s) (pprint v) (val t)
-
-
-checkTerminationExpr :: (Eq v, PPrint v)
- => F.TCEmb TyCon
- -> F.SEnv F.SortedReft
- -> (v, LocSpecType, [F.Located F.Expr])
- -> Diagnostics
-checkTerminationExpr emb env (v, Loc l _ t, les)
- = (mkErr "ill-sorted" $ go les) <> (mkErr "non-numeric" $ go' les)
- where
- -- es = val <$> les
- mkErr :: Doc -> Maybe (F.Expr, Doc) -> Diagnostics
- mkErr _ Nothing = emptyDiagnostics
- mkErr k (Just e) =
- mkDiagnostics mempty [uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) k e t d) e]
- -- mkErr = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) (text "ill-sorted" ) e t d)
- -- mkErr' = uncurry (\ e d -> ErrTermSpec (GM.sourcePosSrcSpan l) (pprint v) (text "non-numeric") e t d)
-
- go :: [F.Located F.Expr] -> Maybe (F.Expr, Doc)
- go = L.foldl' (\err e -> err <|> (val e,) <$> checkSorted (F.srcSpan e) env' (val e)) Nothing
-
- go' :: [F.Located F.Expr] -> Maybe (F.Expr, Doc)
- go' = L.foldl' (\err e -> err <|> (val e,) <$> checkSorted (F.srcSpan e) env' (cmpZero e)) Nothing
-
- env' = F.sr_sort <$> L.foldl' (\e (x,s) -> F.insertSEnv x s e) env xts
- 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 (x, t) = [(x, rSort t)]
-
- rSort = rTypeSortedReft emb
- cmpZero e = F.PAtom F.Le (F.expr (0 :: Int)) (val e)
-
-checkTy :: Bool
- -> BScope
- -> (Doc -> Error)
- -> F.TCEmb TyCon
- -> Bare.TyConMap
- -> F.SEnv F.SortedReft
- -> LocSpecType
- -> Diagnostics
-checkTy allowHO bsc mkE emb tcEnv env t =
- case checkRType allowHO bsc emb env (Bare.txRefSort tcEnv emb t) of
- Nothing -> emptyDiagnostics
- Just d -> mkDiagnostics mempty [mkE d]
- where
- _msg = "CHECKTY: " ++ showpp (val t)
-
-checkDupIntersect :: [(Var, LocSpecType)] -> [(Var, LocSpecType)] -> Diagnostics
-checkDupIntersect xts asmSigs =
- mkDiagnostics (map mkWrn {- trace msg -} dups) mempty
- where
- mkWrn (x, t) = mkWarning (GM.sourcePosSrcSpan $ loc t) (pprWrn x)
- dups = L.intersectBy ((==) `on` fst) asmSigs xts
- pprWrn v = text $ "Assume Overwrites Specifications for " ++ show v
- -- msg = "CHECKDUPINTERSECT:" ++ msg1 ++ msg2
- -- msg1 = "\nCheckd-SIGS:\n" ++ showpp (M.fromList xts)
- -- msg2 = "\nAssume-SIGS:\n" ++ showpp (M.fromList asmSigs)
-
-
-checkDuplicate :: [(Var, LocSpecType)] -> Diagnostics
-checkDuplicate = mkDiagnostics mempty . checkUnique' fst (GM.fSrcSpan . snd)
-
-checkClassMethods :: Maybe [ClsInst] -> [Var] -> [(Var, LocSpecType)] -> Diagnostics
-checkClassMethods Nothing _ _ = emptyDiagnostics
-checkClassMethods (Just clsis) cms xts =
- mkDiagnostics mempty [ErrMClass (GM.sourcePosSrcSpan $ loc t) (pprint x)| (x,t) <- dups ]
- where
- dups = F.notracepp "DPS" $ filter ((`elem` ms) . fst) xts'
- ms = F.notracepp "MS" $ concatMap (classMethods . is_cls) clsis
- xts' = F.notracepp "XTS" $ filter (not . (`elem` cls) . fst) xts
- cls = F.notracepp "CLS" cms
-
--- checkDuplicate xts = mkErr <$> dups
- -- where
- -- mkErr (x, ts) = ErrDupSpecs (getSrcSpan x) (pprint x) (GM.fSrcSpan <$> ts)
- -- dups = [z | z@(_, _:_:_) <- M.toList $ group xts ]
-
-checkDuplicateRTAlias :: String -> [Located (RTAlias s a)] -> Diagnostics
-checkDuplicateRTAlias s tas = mkDiagnostics mempty (map mkErr dups)
- where
- mkErr xs@(x:_) = ErrDupAlias (GM.fSrcSpan x)
- (text s)
- (pprint . rtName . val $ x)
- (GM.fSrcSpan <$> xs)
- mkErr [] = panic Nothing "mkError: called on empty list"
- dups = [z | z@(_:_:_) <- L.groupBy ((==) `on` (rtName . val)) tas]
-
-
-checkMismatch :: (Var, LocSpecType) -> Diagnostics
-checkMismatch (x, t) = if ok then emptyDiagnostics else mkDiagnostics mempty [err]
- where
- ok = tyCompat x (val t')
- err = errTypeMismatch x t'
- t' = dropImplicits <$> t
-
-tyCompat :: Var -> RType RTyCon RTyVar r -> Bool
-tyCompat x t = lqT == hsT
- where
- lqT :: RSort = toRSort t
- hsT :: RSort = ofType (varType x)
- _msg = "TY-COMPAT: " ++ GM.showPpr x ++ ": hs = " ++ F.showpp hsT ++ " :lq = " ++ F.showpp lqT
-
-errTypeMismatch :: Var -> Located SpecType -> Error
-errTypeMismatch x t = ErrMismatch lqSp (pprint x) (text "Checked") d1 d2 Nothing hsSp
- where
- d1 = pprint $ varType x
- d2 = pprint $ toType $ val t
- lqSp = GM.fSrcSpan t
- hsSp = getSrcSpan x
-
-------------------------------------------------------------------------------------------------
--- | @checkRType@ determines if a type is malformed in a given environment ---------------------
-------------------------------------------------------------------------------------------------
-checkRType :: Bool -> BScope -> F.TCEmb TyCon -> F.SEnv F.SortedReft -> LocSpecType -> Maybe Doc
-------------------------------------------------------------------------------------------------
-checkRType allowHO bsc emb env lt
- = checkAppTys t
- <|> checkAbstractRefs t
- <|> efoldReft farg bsc cb (tyToBind emb) (rTypeSortedReft emb) f insertPEnv env Nothing t
- where
- t = val lt
- cb c ts = classBinds emb (rRCls c ts)
- farg _ t = allowHO || isBase t -- NOTE: this check should be the same as the one in addCGEnv
- f env me r err = err <|> checkReft (F.srcSpan lt) env emb me r
- insertPEnv p γ = insertsSEnv γ (Misc.mapSnd (rTypeSortedReft emb) <$> pbinds p)
- pbinds p = (pname p, pvarRType p :: RSort) : [(x, tx) | (tx, x, _) <- pargs p]
-
-tyToBind :: F.TCEmb TyCon -> RTVar RTyVar RSort -> [(F.Symbol, F.SortedReft)]
-tyToBind emb = go . ty_var_info
- where
- go (RTVInfo {..}) = [(rtv_name, rTypeSortedReft emb rtv_kind)]
- go (RTVNoInfo {..}) = []
-
-checkAppTys :: RType RTyCon t t1 -> Maybe Doc
-checkAppTys = go
- where
- go (RAllT _ t _) = go t
- go (RAllP _ t) = go t
- go (RApp rtc ts _ _)
- = checkTcArity rtc (length ts) <|>
- L.foldl' (\merr t -> merr <|> go t) Nothing ts
- go (RImpF _ t1 t2 _)= go t1 <|> go t2
- go (RFun _ t1 t2 _) = go t1 <|> go t2
- go (RVar _ _) = Nothing
- go (RAllE _ t1 t2) = go t1 <|> go t2
- go (REx _ t1 t2) = go t1 <|> go t2
- go (RAppTy t1 t2 _) = go t1 <|> go t2
- go (RRTy _ _ _ t) = go t
- go (RExprArg _) = Just $ text "Logical expressions cannot appear inside a Haskell type"
- go (RHole _) = Nothing
-
-checkTcArity :: RTyCon -> Arity -> Maybe Doc
-checkTcArity (RTyCon { rtc_tc = tc }) givenArity
- | expectedArity < givenArity
- = Just $ text "Type constructor" <+> pprint tc
- <+> text "expects a maximum" <+> pprint expectedArity
- <+> text "arguments but was given" <+> pprint givenArity
- <+> text "arguments"
- | otherwise
- = Nothing
- where
- expectedArity = tyConRealArity tc
-
-
-checkAbstractRefs
- :: (PPrint t, F.Reftable t, SubsTy RTyVar RSort t, F.Reftable (RTProp RTyCon RTyVar (UReft t))) =>
- RType RTyCon RTyVar (UReft t) -> Maybe Doc
-checkAbstractRefs t = go t
- where
- penv = mkPEnv t
-
- go t@(RAllT _ t1 r) = check (toRSort t :: RSort) r <|> go t1
- go (RAllP _ t) = go t
- go t@(RApp c ts rs r) = check (toRSort t :: RSort) r <|> efold go ts <|> go' c rs
- go t@(RImpF _ t1 t2 r)= check (toRSort t :: RSort) r <|> go t1 <|> go t2
- go t@(RFun _ t1 t2 r) = check (toRSort t :: RSort) r <|> go t1 <|> go t2
- go t@(RVar _ r) = check (toRSort t :: RSort) r
- go (RAllE _ t1 t2) = go t1 <|> go t2
- go (REx _ t1 t2) = go t1 <|> go t2
- go t@(RAppTy t1 t2 r) = check (toRSort t :: RSort) r <|> go t1 <|> go t2
- go (RRTy xts _ _ t) = efold go (snd <$> xts) <|> go t
- go (RExprArg _) = Nothing
- go (RHole _) = Nothing
-
- go' c rs = L.foldl' (\acc (x, y) -> acc <|> checkOne' x y) Nothing (zip rs (rTyConPVs c))
-
- checkOne' (RProp xs (RHole _)) p
- | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]
- = Just $ text "Wrong Arguments in" <+> pprint p
- | length xs /= length (pargs p)
- = Just $ text "Wrong Number of Arguments in" <+> pprint p
- | otherwise
- = Nothing
- checkOne' (RProp xs t) p
- | pvType p /= toRSort t
- = Just $ text "Unexpected Sort in" <+> pprint p
- | or [s1 /= s2 | ((_, s1), (s2, _, _)) <- zip xs (pargs p)]
- = Just $ text "Wrong Arguments in" <+> pprint p
- | length xs /= length (pargs p)
- = Just $ text "Wrong Number of Arguments in" <+> pprint p
- | otherwise
- = go t
-
-
- efold f = L.foldl' (\acc x -> acc <|> f x) Nothing
-
- check s (MkUReft _ (Pr ps)) = L.foldl' (\acc pp -> acc <|> checkOne s pp) Nothing ps
-
- checkOne s p | pvType' p /= s
- = Just $ text "Incorrect Sort:\n\t"
- <+> text "Abstract refinement with type"
- <+> pprint (pvType' p)
- <+> text "is applied to"
- <+> pprint s
- <+> text "\n\t In" <+> pprint p
- | otherwise
- = Nothing
-
- mkPEnv (RAllT _ t _) = mkPEnv t
- mkPEnv (RAllP p t) = p:mkPEnv t
- mkPEnv _ = []
- pvType' p = Misc.safeHead (showpp p ++ " not in env of " ++ showpp t) [pvType q | q <- penv, pname p == pname q]
-
-
-checkReft :: (PPrint r, F.Reftable r, SubsTy RTyVar (RType RTyCon RTyVar ()) r, F.Reftable (RTProp RTyCon RTyVar (UReft r)))
- => F.SrcSpan -> F.SEnv F.SortedReft -> F.TCEmb TyCon -> Maybe (RRType (UReft r)) -> UReft r -> Maybe Doc
-checkReft _ _ _ Nothing _ = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet.
-checkReft sp env emb (Just t) _ = (\z -> dr $+$ z) <$> checkSortedReftFull sp env r
- where
- r = rTypeSortedReft emb t
- dr = text "Sort Error in Refinement:" <+> pprint r
-
--- DONT DELETE the below till we've added pred-checking as well
--- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t)
--- where xs = fromMaybe [] $ params <$> stripRTypeBase t
-
--- checkSig env (x, t)
--- = case filter (not . (`S.member` env)) (freeSymbols t) of
--- [] -> TrueNGUAGE ScopedTypeVariables #-}
--- ys -> errorstar (msg ys)
--- where
--- msg ys = printf "Unkown free symbols: %s in specification for %s \n%s\n" (showpp ys) (showpp x) (showpp t)
-
----------------------------------------------------------------------------------------------------
--- | @checkMeasures@ determines if a measure definition is wellformed -----------------------------
----------------------------------------------------------------------------------------------------
-checkMeasures :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> [Measure SpecType DataCon] -> Diagnostics
----------------------------------------------------------------------------------------------------
-checkMeasures emb env = foldMap (checkMeasure emb env)
-
-checkMeasure :: F.TCEmb TyCon -> F.SEnv F.SortedReft -> Measure SpecType DataCon -> Diagnostics
-checkMeasure emb γ (M name@(Loc src _ n) sort body _ _)
- = mkDiagnostics mempty [ txerror e | Just e <- checkMBody γ emb name sort <$> body ]
- where
- txerror = ErrMeas (GM.sourcePosSrcSpan src) (pprint n)
-
-checkMBody :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))
- => F.SEnv F.SortedReft
- -> F.TCEmb TyCon
- -> t
- -> SpecType
- -> Def (RRType r) DataCon
- -> Maybe Doc
-checkMBody γ emb _ sort (Def m c _ bs body) = checkMBody' emb sort γ' sp body
- where
- sp = F.srcSpan m
- γ' = L.foldl' (\γ (x, t) -> F.insertSEnv x t γ) γ xts
- xts = zip (fst <$> bs) $ rTypeSortedReft emb . subsTyVars_meet su <$> filter (not . isClassType) (ty_args trep)
- trep = toRTypeRep ct
- su = checkMBodyUnify (ty_res trep) (last txs)
- txs = snd4 $ bkArrowDeep sort
- ct = ofType $ dataConUserType c :: SpecType
-
-checkMBodyUnify
- :: RType t t2 t1 -> RType c tv r -> [(t2,RType c tv (),RType c tv r)]
-checkMBodyUnify = go
- where
- go (RVar tv _) t = [(tv, toRSort t, t)]
- go t@(RApp {}) t'@(RApp {}) = concat $ zipWith go (rt_args t) (rt_args t')
- go _ _ = []
-
-checkMBody' :: (PPrint r, F.Reftable r,SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))
- => F.TCEmb TyCon
- -> RType RTyCon RTyVar r
- -> F.SEnv F.SortedReft
- -> F.SrcSpan
- -> Body
- -> Maybe Doc
-checkMBody' emb sort γ sp body = case body of
- E e -> checkSortFull sp γ (rTypeSort emb sort') e
- P p -> checkSortFull sp γ F.boolSort p
- R s p -> checkSortFull sp (F.insertSEnv s sty γ) F.boolSort p
- where
- sty = rTypeSortedReft emb sort'
- sort' = dropNArgs 1 sort
-
-dropNArgs :: Int -> RType RTyCon RTyVar r -> RType RTyCon RTyVar r
-dropNArgs i t = fromRTypeRep $ trep {ty_binds = xs, ty_args = ts, ty_refts = rs}
- where
- xs = drop i $ ty_binds trep
- ts = drop i $ ty_args trep
- rs = drop i $ ty_refts trep
- trep = toRTypeRep t
-
-
-getRewriteErrors :: (Var, Located SpecType) -> [TError t]
-getRewriteErrors (rw, t)
- | null $ refinementEQs t
- = [ErrRewrite (GM.fSrcSpan t) $ text $
- "Unable to use "
- ++ show rw
- ++ " as a rewrite because it does not prove an equality, or the equality it proves is trivial." ]
- | otherwise
- = refErrs ++ if cannotInstantiate then
- [ErrRewrite (GM.fSrcSpan t) $
- text $ "Could not generate any rewrites from equality. Likely causes: "
- ++ "\n - There are free (uninstantiatable) variables on both sides of the "
- ++ "equality\n - The rewrite would diverge"]
- else []
- where
- refErrs = map getInnerRefErr (filter (hasInnerRefinement . fst) (zip tyArgs syms))
- allowedRWs = [ (lhs, rhs) | (lhs , rhs) <- refinementEQs t
- , canRewrite (S.fromList syms) lhs rhs ||
- canRewrite (S.fromList syms) rhs lhs
- ]
- cannotInstantiate = null allowedRWs
- tyArgs = ty_args tRep
- syms = ty_binds tRep
- tRep = toRTypeRep $ val t
- getInnerRefErr (_, sym) =
- ErrRewrite (GM.fSrcSpan t) $ text $
- "Unable to use "
- ++ show rw
- ++ " as a rewrite. Functions whose parameters have inner refinements cannot be used as rewrites, but parameter "
- ++ show sym
- ++ " contains an inner refinement."
-
-
-isRefined :: F.Reftable r => RType c tv r -> Bool
-isRefined ty
- | Just r <- stripRTypeBase ty = not $ F.isTauto r
- | otherwise = False
-
-hasInnerRefinement :: F.Reftable r => RType c tv r -> Bool
-hasInnerRefinement (RFun _ rIn rOut _) =
- isRefined rIn || isRefined rOut
-hasInnerRefinement (RImpF _ rIn rOut _) =
- isRefined rIn || isRefined rOut
-hasInnerRefinement (RAllT _ ty _) =
- isRefined ty
-hasInnerRefinement (RAllP _ ty) =
- isRefined ty
-hasInnerRefinement (RApp _ args _ _) =
- any isRefined args
-hasInnerRefinement (RAllE _ allarg ty) =
- isRefined allarg || isRefined ty
-hasInnerRefinement (REx _ allarg ty) =
- isRefined allarg || isRefined ty
-hasInnerRefinement (RAppTy arg res _) =
- isRefined arg || isRefined res
-hasInnerRefinement (RRTy env _ _ ty) =
- isRefined ty || any (isRefined . snd) env
-hasInnerRefinement _ = False
-
-checkRewrites :: TargetSpec -> Diagnostics
-checkRewrites targetSpec = mkDiagnostics mempty (concatMap getRewriteErrors rwSigs)
- where
- rwSigs = filter ((`S.member` rws) . fst) sigs
- refl = gsRefl targetSpec
- sig = gsSig targetSpec
- sigs = gsTySigs sig ++ gsAsmSigs sig
- rws = S.union (S.map val $ gsRewrites refl)
- (S.fromList $ concat $ M.elems (gsRewritesWith refl))
-
-
-checkClassMeasures :: [Measure SpecType DataCon] -> Diagnostics
-checkClassMeasures ms = mkDiagnostics mempty (mapMaybe checkOne byTyCon)
- where
- byName = L.groupBy ((==) `on` (val . msName)) ms
-
- byTyCon = concatMap (L.groupBy ((==) `on` (dataConTyCon . ctor . head . msEqns)))
- byName
-
- checkOne [] = impossible Nothing "checkClassMeasures.checkOne on empty measure group"
- checkOne [_] = Nothing
- checkOne (m:ms) = Just (ErrDupIMeas (GM.fSrcSpan (msName m))
- (pprint (val (msName m)))
- (pprint ((dataConTyCon . ctor . head . msEqns) m))
- (GM.fSrcSpan <$> (m:ms)))
-
-
-
diff --git a/src/Language/Haskell/Liquid/Bare/Class.hs b/src/Language/Haskell/Liquid/Bare/Class.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Class.hs
+++ /dev/null
@@ -1,276 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ParallelListComp #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE BangPatterns #-}
-
-module Language.Haskell.Liquid.Bare.Class
- ( makeClasses
- , makeCLaws
- , makeSpecDictionaries
- , makeDefaultMethods
- , makeMethodTypes
- )
- where
-
-import Data.Bifunctor
-import qualified Data.Maybe as Mb
-import qualified Data.List as L
-import qualified Data.HashMap.Strict as M
-
-import qualified Language.Fixpoint.Misc as Misc
-import qualified Language.Fixpoint.Types as F
-import qualified Language.Fixpoint.Types.Visitor as F
-
-import Language.Haskell.Liquid.Types.Dictionaries
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import Language.Haskell.Liquid.Misc
-import Language.Haskell.Liquid.Types.RefType
-import Language.Haskell.Liquid.Types hiding (freeTyVars)
-
-import qualified Language.Haskell.Liquid.Measure as Ms
-import Language.Haskell.Liquid.Bare.Types as Bare
-import Language.Haskell.Liquid.Bare.Resolve as Bare
-import Language.Haskell.Liquid.Bare.Expand as Bare
-import Language.Haskell.Liquid.Bare.Misc as Bare
-
-import Text.PrettyPrint.HughesPJ (text)
-import qualified Control.Exception as Ex
-
-
-
--------------------------------------------------------------------------------
-makeMethodTypes :: DEnv Ghc.Var LocSpecType -> [DataConP] -> [Ghc.CoreBind] -> [(Ghc.Var, MethodType LocSpecType)]
--------------------------------------------------------------------------------
-makeMethodTypes (DEnv m) cls cbs
- = [(x, MT (addCC x . fromRISig <$> methodType d x m) (addCC x <$> classType (splitDictionary e) x)) | (d,e) <- ds, x <- grepMethods e]
- where
- grepMethods = filter GM.isMethod . freeVars mempty
- ds = filter (GM.isDictionary . fst) (concatMap unRec cbs)
- unRec (Ghc.Rec xes) = xes
- unRec (Ghc.NonRec x e) = [(x,e)]
-
- classType Nothing _ = Nothing
- classType (Just (d, ts, _)) x =
- case filter ((==d) . Ghc.dataConWorkId . dcpCon) cls of
- (di:_) -> fmap ((dcpLoc di `F.atLoc`) . subst (zip (dcpFreeTyVars di) ts)) $ L.lookup (mkSymbol x) (dcpTyArgs di)
- _ -> Nothing
-
- methodType d x m = ihastype (M.lookup d m) x
-
- ihastype Nothing _ = Nothing
- ihastype (Just xts) x = M.lookup (mkSymbol x) xts
-
- mkSymbol x = F.dropSym 2 $ GM.simplesymbol x
-
- subst [] t = t
- subst ((a,ta):su) t = subsTyVar_meet' (a,ofType ta) (subst su t)
-
-addCC :: Ghc.Var -> LocSpecType -> LocSpecType
-addCC x zz@(Loc l l' st0)
- = Loc l l'
- . addForall hst
- . mkArrow [] ps' [] []
- . makeCls cs'
- . mapExprReft (\_ -> F.applyCoSub coSub)
- . subts su
- $ st
- where
- hst = ofType (Ghc.expandTypeSynonyms t0) :: SpecType
- t0 = Ghc.varType x
- tyvsmap = case Bare.runMapTyVars t0 st err of
- Left e -> Ex.throw e
- Right s -> Bare.vmap s
- su = [(y, rTyVar x) | (x, y) <- tyvsmap]
- su' = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]
- coSub = M.fromList [(F.symbol y, F.FObj (F.symbol x)) | (y, x) <- su]
- ps' = fmap (subts su') <$> ps
- cs' = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs ]
- (_,_,cs,_) = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)
- (_,ps,_ ,st) = bkUnivClass (F.notracepp "lq-spec" st0)
-
- makeCls cs t = foldr (uncurry rFun) t cs
- err hsT lqT = ErrMismatch (GM.fSrcSpan zz) (pprint x)
- (text "makeMethodTypes")
- (pprint $ Ghc.expandTypeSynonyms t0)
- (pprint $ toRSort st0)
- (Just (hsT, lqT))
- (Ghc.getSrcSpan x)
-
- addForall (RAllT v t r) tt@(RAllT v' _ _)
- | v == v'
- = tt
- | otherwise
- = RAllT (updateRTVar v) (addForall t tt) r
- addForall (RAllT v t r) t'
- = RAllT (updateRTVar v) (addForall t t') r
- addForall (RAllP _ t) t'
- = addForall t t'
- addForall _ (RAllP p t')
- = RAllP (fmap (subts su') p) t'
- addForall (RFun _ t1 t2 _) (RFun x t1' t2' r)
- = RFun x (addForall t1 t1') (addForall t2 t2') r
- addForall _ t
- = t
-
-
-splitDictionary :: Ghc.CoreExpr -> Maybe (Ghc.Var, [Ghc.Type], [Ghc.Var])
-splitDictionary = go [] []
- where
- go ts xs (Ghc.App e (Ghc.Tick _ a)) = go ts xs (Ghc.App e a)
- go ts xs (Ghc.App e (Ghc.Type t)) = go (t:ts) xs e
- go ts xs (Ghc.App e (Ghc.Var x)) = go ts (x:xs) e
- go ts xs (Ghc.Tick _ t) = go ts xs t
- go ts xs (Ghc.Var x) = Just (x, reverse ts, reverse xs)
- go _ _ _ = Nothing
-
-
--------------------------------------------------------------------------------
-makeCLaws :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs
- -> [(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])]
--------------------------------------------------------------------------------
-makeCLaws env sigEnv myName specs =
- [ (Mb.fromMaybe (msg tc) (Ghc.tyConClass_maybe tc), snd cls) | (name, spec) <- M.toList specs
- , cls <- Ms.claws spec
- , tc <- Mb.maybeToList (classTc cls)
- , cls <- Mb.maybeToList (mkClass env sigEnv myName name cls tc)
- ]
- where
- msg tc = error ("Not a type class: " ++ F.showpp tc)
- classTc = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName
-
-
-
--------------------------------------------------------------------------------
-makeClasses :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.ModSpecs
- -> ([DataConP], [(ModName, Ghc.Var, LocSpecType)])
--------------------------------------------------------------------------------
-makeClasses env sigEnv myName specs =
- second mconcat . unzip
- $ [ cls | (name, spec) <- M.toList specs
- , cls <- Ms.classes spec
- , tc <- Mb.maybeToList (classTc cls)
- , cls <- Mb.maybeToList (mkClass env sigEnv myName name cls tc)
- ]
- where
- classTc = Bare.maybeResolveSym env myName "makeClass" . btc_tc . rcName
-
-mkClass :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon
- -> Maybe (DataConP, [(ModName, Ghc.Var, LocSpecType)])
-mkClass env sigEnv _myName name (RClass cc ss as ms)
- = Bare.failMaybe env name
- . mkClassE env sigEnv _myName name (RClass cc ss as ms)
-
-mkClassE :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> RClass LocBareType -> Ghc.TyCon
- -> Either UserError (DataConP, [(ModName, Ghc.Var, LocSpecType)])
-mkClassE env sigEnv _myName name (RClass cc ss as ms) tc = do
- ss' <- mapM (mkConstr env sigEnv name) ss
- meths <- mapM (makeMethod env sigEnv name) ms'
- let vts = [ (m, v, t) | (m, kv, t) <- meths, v <- Mb.maybeToList (plugSrc kv) ]
- let sts = [(val s, unClass $ val t) | (s, _) <- ms | (_, _, t) <- meths]
- let dcp = DataConP l dc αs [] (val <$> ss') (reverse sts) t False (F.symbol name) l'
- return $ F.notracepp msg (dcp, vts)
- where
- c = btc_tc cc
- l = loc c
- l' = locE c
- msg = "MKCLASS: " ++ F.showpp (cc, as, αs)
- (dc:_) = Ghc.tyConDataCons tc
- αs = bareRTyVar <$> as
- as' = [rVar $ GM.symbolTyVar $ F.symbol a | a <- as ]
- ms' = [ (s, rFun "" (RApp cc (flip RVar mempty <$> as) [] mempty) <$> t) | (s, t) <- ms]
- t = rCls tc as'
-
-mkConstr :: Bare.Env -> Bare.SigEnv -> ModName -> LocBareType -> Either UserError LocSpecType
-mkConstr env sigEnv name = fmap (fmap dropUniv) . Bare.cookSpecTypeE env sigEnv name Bare.GenTV
- where
- dropUniv t = t' where (_, _, t') = bkUniv t
-
- --FIXME: cleanup this code
-unClass :: SpecType -> SpecType
-unClass = snd . bkClass . thrd3 . bkUniv
-
-makeMethod :: Bare.Env -> Bare.SigEnv -> ModName -> (LocSymbol, LocBareType)
- -> Either UserError (ModName, PlugTV Ghc.Var, LocSpecType)
-makeMethod env sigEnv name (lx, bt) = (name, mbV,) <$> Bare.cookSpecTypeE env sigEnv name mbV bt
- where
- mbV = case Bare.maybeResolveSym env name "makeMethod" lx of
- Just v -> Bare.LqTV v
- Nothing -> Bare.GenTV
-
--------------------------------------------------------------------------------
-makeSpecDictionaries :: Bare.Env -> Bare.SigEnv -> ModSpecs -> DEnv Ghc.Var LocSpecType
--------------------------------------------------------------------------------
-makeSpecDictionaries env sigEnv specs
- = dfromList
- . concat
- . fmap (makeSpecDictionary env sigEnv)
- $ M.toList specs
-
-makeSpecDictionary :: Bare.Env -> Bare.SigEnv -> (ModName, Ms.BareSpec)
- -> [(Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]
-makeSpecDictionary env sigEnv (name, spec)
- = Mb.catMaybes
- . resolveDictionaries env name
- . fmap (makeSpecDictionaryOne env sigEnv name)
- . Ms.rinstance
- $ spec
-
-makeSpecDictionaryOne :: Bare.Env -> Bare.SigEnv -> ModName
- -> RInstance LocBareType
- -> (F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))
-makeSpecDictionaryOne env sigEnv name (RI x t xts)
- = makeDictionary $ F.notracepp "RI" $ RI x ts [(x, mkLSpecIType t) | (x, t) <- xts ]
- where
- ts = mkTy' <$> t
- as = concatMap (univs . val) ts
- univs t = (\(RTVar tv _, _) -> tv) <$> as where (as, _, _) = bkUniv t
-
- mkTy' :: LocBareType -> LocSpecType
- mkTy' = Bare.cookSpecType env sigEnv name Bare.GenTV
- mkTy :: LocBareType -> LocSpecType
- mkTy = fmap (mapUnis tidy) . Bare.cookSpecType env sigEnv name
- Bare.GenTV -- (Bare.HsTV (Bare.lookupGhcVar env name "rawDictionaries" x))
- mapUnis f t = mkUnivs (f as) ps t0 where (as, ps, t0) = bkUniv t
-
- tidy vs = l ++ r
- where (l,r) = L.partition (\(RTVar tv _,_) -> tv `elem` as) vs
-
- mkLSpecIType :: RISig LocBareType -> RISig LocSpecType
- mkLSpecIType t = fmap mkTy t
-
-resolveDictionaries :: Bare.Env -> ModName -> [(F.Symbol, M.HashMap F.Symbol (RISig LocSpecType))]
- -> [Maybe (Ghc.Var, M.HashMap F.Symbol (RISig LocSpecType))]
-resolveDictionaries env name = fmap lookupVar
- . concat
- . fmap addInstIndex
- . Misc.groupList
- where
- lookupVar (x, inst) = (, inst) <$> Bare.maybeResolveSym env name "resolveDict" (F.dummyLoc x)
-
--- formerly, addIndex
--- GHC internal postfixed same name dictionaries with ints
-addInstIndex :: (F.Symbol, [a]) -> [(F.Symbol, a)]
-addInstIndex (x, is) = go 0 (reverse is)
- where
- go _ [] = []
- go _ [i] = [(x, i)]
- go j (i:is) = (F.symbol (F.symbolString x ++ show j),i) : go (j+1) is
-
-----------------------------------------------------------------------------------
-makeDefaultMethods :: Bare.Env -> [(ModName, Ghc.Var, LocSpecType)]
- -> [(ModName, Ghc.Var, LocSpecType)]
-----------------------------------------------------------------------------------
-makeDefaultMethods env mts = [ (mname, dm, t)
- | (mname, m, t) <- mts
- , dm <- lookupDefaultVar env mname m ]
-
-lookupDefaultVar :: Bare.Env -> ModName -> Ghc.Var -> [Ghc.Var]
-lookupDefaultVar env name v = Mb.maybeToList
- . Bare.maybeResolveSym env name "default-method"
- $ dmSym
- where
- dmSym = F.atLoc v (GM.qualifySymbol mSym dnSym)
- dnSym = F.mappendSym "$dm" nSym
- (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
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/DataType.hs
+++ /dev/null
@@ -1,690 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-
-module Language.Haskell.Liquid.Bare.DataType
- ( dataConMap
-
- -- * Names for accessing Data Constuctors
- , makeDataConChecker
- , makeDataConSelector
- , addClassEmbeds
-
- -- * Constructors
- , makeDataDecls
- , makeConTypes
- , makeRecordSelectorSigs
- , meetDataConSpec
- -- , makeTyConEmbeds
-
- ) where
-
-import Prelude hiding (error)
-
--- import Text.Parsec
--- import Var
--- import Data.Maybe
--- import Language.Haskell.Liquid.GHC.TypeRep
-
-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 Language.Fixpoint.Types.Visitor as V
-import qualified Language.Fixpoint.Types as F
-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)
-import qualified Language.Haskell.Liquid.Types.RefType as RT
-import Language.Haskell.Liquid.Types.Types
-import Language.Haskell.Liquid.Types.Meet
-import qualified Language.Fixpoint.Misc as Misc
-import qualified Language.Haskell.Liquid.Misc as Misc
-import Language.Haskell.Liquid.Types.Variance
-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.Misc as GM
--- import Language.Haskell.Liquid.Bare.Env
--- import Language.Haskell.Liquid.Bare.Lookup
--- import Language.Haskell.Liquid.Bare.OfType
-
-import Text.Printf (printf)
-import Text.PrettyPrint.HughesPJ ((<+>))
--- import Debug.Trace (trace)
-
---------------------------------------------------------------------------------
--- | 'DataConMap' stores the names of those ctor-fields that have been declared
--- as SMT ADTs so we don't make up new names for them.
---------------------------------------------------------------------------------
-dataConMap :: [F.DataDecl] -> Bare.DataConMap
-dataConMap ds = M.fromList $ do
- d <- ds
- c <- F.ddCtors d
- let fs = F.symbol <$> F.dcFields c
- zip ((F.symbol c,) <$> [1..]) fs
-
-
---------------------------------------------------------------------------------
--- | 'makeDataConChecker d' creates the measure for `is$d` which tests whether
--- a given value was created by 'd'. e.g. is$Nil or is$Cons.
---------------------------------------------------------------------------------
-makeDataConChecker :: Ghc.DataCon -> F.Symbol
---------------------------------------------------------------------------------
-makeDataConChecker = F.testSymbol . F.symbol
-
---------------------------------------------------------------------------------
--- | 'makeDataConSelector d' creates the selector `select$d$i`
--- which projects the i-th field of a constructed value.
--- e.g. `select$Cons$1` and `select$Cons$2` are respectively
--- equivalent to `head` and `tail`.
---------------------------------------------------------------------------------
-makeDataConSelector :: Maybe Bare.DataConMap -> Ghc.DataCon -> Int -> F.Symbol
-makeDataConSelector dmMb d i = M.lookupDefault def (F.symbol d, i) dm
- where
- dm = Mb.fromMaybe M.empty dmMb
- def = makeDataConSelector' d i
-
-
-makeDataConSelector' :: Ghc.DataCon -> Int -> F.Symbol
-makeDataConSelector' d i
- = symbolMeasure "$select" (dcSymbol d) (Just i)
-
-dcSymbol :: Ghc.DataCon -> F.Symbol
-dcSymbol = {- simpleSymbolVar -} F.symbol . Ghc.dataConWorkId
-
-symbolMeasure :: String -> F.Symbol -> Maybe Int -> F.Symbol
-symbolMeasure f d iMb = foldr1 F.suffixSymbol (dcPrefix : F.symbol f : d : rest)
- where
- rest = maybe [] (Misc.singleton . F.symbol . show) iMb
-
-
---------------------------------------------------------------------------------
--- | makeClassEmbeds: sort-embeddings for numeric, and family-instance tycons
---------------------------------------------------------------------------------
-addClassEmbeds :: Maybe [Ghc.ClsInst] -> [Ghc.TyCon] -> F.TCEmb Ghc.TyCon
- -> F.TCEmb Ghc.TyCon
-addClassEmbeds instenv fiTcs = makeFamInstEmbeds fiTcs . makeNumEmbeds instenv
-
---------------------------------------------------------------------------------
--- | makeFamInstEmbeds : embed family instance tycons, see [NOTE:FamInstEmbeds]
---------------------------------------------------------------------------------
--- Query.R$58$EntityFieldBlobdog
--- with the actual family instance types that have numeric instances as int [Check!]
---------------------------------------------------------------------------------
-makeFamInstEmbeds :: [Ghc.TyCon] -> F.TCEmb Ghc.TyCon -> F.TCEmb Ghc.TyCon
-makeFamInstEmbeds cs0 embs = L.foldl' embed embs famInstSorts
- where
- famInstSorts = F.notracepp "famInstTcs"
- [ (c, RT.typeSort embs ty)
- | c <- cs
- , ty <- Mb.maybeToList (RT.famInstTyConType c) ]
- embed embs (c, t) = F.tceInsert c t F.NoArgs embs
- cs = F.notracepp "famInstTcs-all" cs0
-
-{-
-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 (famInstType (Ghc.tyConArity c) c' ts)
- Nothing -> Nothing
-
-famInstType :: Int -> Ghc.TyCon -> [Ghc.Type] -> Ghc.Type
-famInstType n c ts = Ghc.mkTyConApp c (take (length ts - n) ts)
--}
-
-{- | [NOTE:FamInstEmbeds] GHC represents family instances in two ways:
-
- (1) As an applied type,
- (2) As a special tycon.
-
- For example, consider `tests/pos/ExactGADT4.hs`:
-
- class PersistEntity record where
- data EntityField record :: * -> *
-
- data Blob = B { xVal :: Int, yVal :: Int }
-
- instance PersistEntity Blob where
- data EntityField Blob dog where
- BlobXVal :: EntityField Blob Int
- BlobYVal :: EntityField Blob Int
-
- here, the type of the constructor `BlobXVal` can be represented as:
-
- (1) EntityField Blob Int,
-
- or
-
- (2) R$58$EntityFieldBlobdog Int
-
- PROBLEM: For various reasons, GHC will use _both_ representations interchangeably,
- which messes up our sort-checker.
-
- SOLUTION: To address the above, we create an "embedding"
-
- R$58$EntityFieldBlobdog :-> EntityField Blob
-
- So that all occurrences of the (2) are treated as (1) by the sort checker.
-
- -}
-
---------------------------------------------------------------------------------
--- | makeNumEmbeds: embed types that have numeric instances as int [Check!]
---------------------------------------------------------------------------------
-makeNumEmbeds :: Maybe [Ghc.ClsInst] -> F.TCEmb Ghc.TyCon -> F.TCEmb Ghc.TyCon
-makeNumEmbeds Nothing x = x
-makeNumEmbeds (Just is) x = L.foldl' makeNumericInfoOne x is
-
-makeNumericInfoOne :: F.TCEmb Ghc.TyCon -> Ghc.ClsInst -> F.TCEmb Ghc.TyCon
-makeNumericInfoOne m is
- | isFracCls cls, Just tc <- instanceTyCon is
- = F.tceInsertWith (flip mappendSortFTC) tc (ftc tc True True) F.NoArgs m
- | isNumCls cls, Just tc <- instanceTyCon is
- = F.tceInsertWith (flip mappendSortFTC) tc (ftc tc True False) F.NoArgs m
- | otherwise
- = m
- where
- cls = Ghc.classTyCon (Ghc.is_cls is)
- ftc c f1 f2 = F.FTC (F.symbolNumInfoFTyCon (dummyLoc $ RT.tyConName c) f1 f2)
-
-mappendSortFTC :: F.Sort -> F.Sort -> F.Sort
-mappendSortFTC (F.FTC x) (F.FTC y) = F.FTC (F.mappendFTC x y)
-mappendSortFTC s (F.FTC _) = s
-mappendSortFTC (F.FTC _) s = s
-mappendSortFTC s1 s2 = panic Nothing ("mappendSortFTC: s1 = " ++ showpp s1 ++ " s2 = " ++ showpp s2)
-
-instanceTyCon :: Ghc.ClsInst -> Maybe Ghc.TyCon
-instanceTyCon = go . Ghc.is_tys
- where
- go [Ghc.TyConApp c _] = Just c
- go _ = Nothing
-
---------------------------------------------------------------------------------
--- | Create Fixpoint DataDecl from LH DataDecls --------------------------------
---------------------------------------------------------------------------------
-
--- | A 'DataPropDecl' is associated with a (`TyCon` and) `DataDecl`, and defines the
--- sort of relation that is established by terms of the given `TyCon`.
--- A 'DataPropDecl' say, 'pd' is associated with a 'dd' of type 'DataDecl' when
--- 'pd' is the `SpecType` version of the `BareType` given by `tycPropTy dd`.
-
-type DataPropDecl = (DataDecl, Maybe SpecType)
-
-makeDataDecls :: Config -> F.TCEmb Ghc.TyCon -> ModName
- -> [(ModName, Ghc.TyCon, DataPropDecl)]
- -> [Located DataConP]
- -> [F.DataDecl]
-makeDataDecls cfg tce name tds ds
- | makeDecls = [ makeFDataDecls tce tc dd ctors
- | (tc, (dd, ctors)) <- groupDataCons tds' (F.notracepp "makeDataDecls" ds)
- , tc /= Ghc.listTyCon
- ]
- | otherwise = []
- where
- makeDecls = exactDCFlag cfg && not (noADT cfg)
- tds' = resolveTyCons name tds
-
--- [NOTE:Orphan-TyCons]
-
-{- | 'resolveTyCons' will prune duplicate 'TyCon' definitions, as follows:
-
- Let the "home" of a 'TyCon' be the module where it is defined.
- There are three kinds of 'DataDecl' definitions:
-
- 1. A "home"-definition is one that belongs to its home module,
- 2. An "orphan"-definition is one that belongs to some non-home module.
-
- A 'DataUser' definition MUST be a "home" definition
- - otherwise you can avoid importing the definition
- and hence, unsafely pass its invariants!
-
- So, 'resolveTyConDecls' implements the following protocol:
-
- (a) If there is a "Home" definition,
- then use it, and IGNORE others.
-
- (b) If there are ONLY "orphan" definitions,
- then pick the one from module being analyzed.
-
- We COULD relax to allow for exactly one orphan `DataUser` definition
- which is the one that should be selected, but that seems like a
- slippery slope, as you can avoid importing the definition
- and hence, unsafely pass its invariants! (Feature not bug?)
-
--}
-resolveTyCons :: ModName -> [(ModName, Ghc.TyCon, DataPropDecl)]
- -> [(Ghc.TyCon, (ModName, DataPropDecl))]
-resolveTyCons m mtds = [(tc, (m, d)) | (tc, mds) <- M.toList tcDecls
- , (m, d) <- Mb.maybeToList $ resolveDecls m tc mds ]
- where
- tcDecls = Misc.group [ (tc, (m, d)) | (m, tc, d) <- mtds ]
-
--- | See [NOTE:Orphan-TyCons], the below function tells us which of (possibly many)
--- DataDecls to use.
-resolveDecls :: ModName -> Ghc.TyCon -> Misc.ListNE (ModName, DataPropDecl)
- -> Maybe (ModName, DataPropDecl)
-resolveDecls mName tc mds = F.notracepp msg $ Misc.firstMaybes $ (`L.find` mds) <$> [ isHomeDef , isMyDef]
- where
- msg = "resolveDecls" ++ F.showpp (mName, tc)
- isMyDef = (mName ==) . fst
- isHomeDef = (tcHome ==) . F.symbol . fst
- tcHome = GM.takeModuleNames (F.symbol tc)
-
-groupDataCons :: [(Ghc.TyCon, (ModName, DataPropDecl))]
- -> [Located DataConP]
- -> [(Ghc.TyCon, (DataPropDecl, [(Ghc.DataCon, DataConP)]))]
-groupDataCons tds ds = [ (tc, (d, dds')) | (tc, ((m, d), dds)) <- tcDataCons
- , let dds' = filter (isResolvedDataConP m . snd) dds
- ]
- where
- tcDataCons = M.toList $ M.intersectionWith (,) declM ctorM
- declM = M.fromList tds
- ctorM = Misc.group [(Ghc.dataConTyCon d, (d, dcp)) | Loc _ _ dcp <- ds, let d = dcpCon dcp]
-
-isResolvedDataConP :: ModName -> DataConP -> Bool
-isResolvedDataConP m dp = F.symbol m == dcpModule dp
-
-makeFDataDecls :: F.TCEmb Ghc.TyCon -> Ghc.TyCon -> DataPropDecl -> [(Ghc.DataCon, DataConP)]
- -> F.DataDecl
-makeFDataDecls tce tc dd ctors = makeDataDecl tce tc (fst dd) ctors
- -- ++ maybeToList (makePropDecl tce tc dd) -- TODO: AUTO-INDPRED
-
-makeDataDecl :: F.TCEmb Ghc.TyCon -> Ghc.TyCon -> DataDecl -> [(Ghc.DataCon, DataConP)]
- -> F.DataDecl
-makeDataDecl tce tc dd ctors
- = F.DDecl
- { F.ddTyCon = ftc
- , F.ddVars = length $ GM.tyConTyVarsDef tc
- , F.ddCtors = makeDataCtor tce ftc <$> ctors
- }
- where
- ftc = F.symbolFTycon (tyConLocSymbol tc dd)
-
-tyConLocSymbol :: Ghc.TyCon -> DataDecl -> LocSymbol
-tyConLocSymbol tc dd = F.atLoc (tycName dd) (F.symbol tc)
-
--- [NOTE:ADT] We need to POST-PROCESS the 'Sort' so that:
--- 1. The poly tyvars are replaced with debruijn
--- versions e.g. 'List a_a1m' becomes 'List @(1)'
--- 2. The "self" type is replaced with just itself
--- (i.e. without any type applications.)
-
-makeDataCtor :: F.TCEmb Ghc.TyCon -> F.FTycon -> (Ghc.DataCon, DataConP) -> F.DataCtor
-makeDataCtor tce c (d, dp) = F.DCtor
- { F.dcName = GM.namedLocSymbol d
- , F.dcFields = makeDataFields tce c as xts
- }
- where
- as = dcpFreeTyVars dp
- xts = [ (fld x, t) | (x, t) <- reverse (dcpTyArgs dp) ]
- fld = F.atLoc dp . fieldName d dp
-
-fieldName :: Ghc.DataCon -> DataConP -> F.Symbol -> F.Symbol
-fieldName d dp x
- | dcpIsGadt dp = F.suffixSymbol (F.symbol d) x
- | otherwise = x
-
-makeDataFields :: F.TCEmb Ghc.TyCon -> F.FTycon -> [RTyVar] -> [(F.LocSymbol, SpecType)]
- -> [F.DataField]
-makeDataFields tce _c as xts = [ F.DField x (fSort t) | (x, t) <- xts]
- where
- su = zip (F.symbol <$> as) [0..]
- fSort = F.substVars su . F.mapFVar (+ (length as)) . RT.rTypeSort tce
-
-{-
-muSort :: F.FTycon -> Int -> F.Sort -> F.Sort
-muSort c n = V.mapSort tx
- where
- ct = F.fTyconSort c
- me = F.fTyconSelfSort c n
- tx t = if t == me then ct else t
--}
-
---------------------------------------------------------------------------------
-meetDataConSpec :: F.TCEmb Ghc.TyCon -> [(Ghc.Var, SpecType)] -> [DataConP]
- -> [(Ghc.Var, SpecType)]
---------------------------------------------------------------------------------
-meetDataConSpec emb xts dcs = M.toList $ snd <$> L.foldl' upd dcm0 xts
- where
- dcm0 = M.fromList (dataConSpec' dcs)
- upd dcm (x, t) = M.insert x (Ghc.getSrcSpan x, tx') dcm
- where
- tx' = maybe t (meetX x t) (M.lookup x dcm)
- meetX x t (sp', t') = F.notracepp (_msg x t t') $ meetVarTypes emb (pprint x) (Ghc.getSrcSpan x, t) (sp', t')
- _msg x t t' = "MEET-VAR-TYPES: " ++ showpp (x, t, t')
-
-dataConSpec' :: [DataConP] -> [(Ghc.Var, (Ghc.SrcSpan, SpecType))]
-dataConSpec' = concatMap tx
- where
- tx dcp = [ (x, res) | (x, t0) <- dataConPSpecType dcp
- , let t = RT.expandProductType x t0
- , let res = (GM.fSrcSpan dcp, t)
- ]
---------------------------------------------------------------------------------
--- | Bare Predicate: DataCon Definitions ---------------------------------------
---------------------------------------------------------------------------------
-makeConTypes :: Bare.Env -> (ModName, Ms.BareSpec)
- -> ([(ModName, TyConP, Maybe DataPropDecl)], [[Located DataConP]])
-makeConTypes env (name, spec)
- = unzip [ ofBDataDecl env name x y | (x, y) <- gvs ]
- where
- gvs = groupVariances dcs' vdcs
- dcs' = canonizeDecls env name dcs
- dcs = Ms.dataDecls spec
- vdcs = Ms.dvariance spec
-
--- | '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
--- instead of the unlifted versions.
-
-canonizeDecls :: Bare.Env -> ModName -> [DataDecl] -> [DataDecl]
-canonizeDecls env name ds =
- case Misc.uniqueByKey' selectDD kds of
- Left decls -> err decls
- Right decls -> decls
- where
- kds = [ (k, d) | d <- ds, k <- Mb.maybeToList (dataDeclKey env name d) ]
- err ds@(d:_) = uError (errDupSpecs (pprint $ tycName d)(GM.fSrcSpan <$> ds))
- err _ = impossible Nothing "canonizeDecls"
-
-dataDeclKey :: Bare.Env -> ModName -> DataDecl -> Maybe F.Symbol
--- dataDeclKey env name = fmap F.symbol . Bare.lookupGhcDnTyCon env name "canonizeDecls" . tycName
-dataDeclKey env name d = do
- tc <- Bare.lookupGhcDnTyCon env name "canonizeDecls" (tycName d)
- _ <- checkDataCtors env name tc (tycDCons d)
- return (F.symbol tc)
-
-checkDataCtors :: Bare.Env -> ModName -> Ghc.TyCon -> [DataCtor] -> Maybe [DataCtor]
-checkDataCtors env name c = mapM (checkDataCtor2 env name c dcs . checkDataCtor1)
- where
- dcs = S.fromList . fmap F.symbol $ Ghc.tyConDataCons c
-
-checkDataCtor2 :: Bare.Env -> ModName -> Ghc.TyCon -> S.HashSet F.Symbol -> DataCtor
- -> Maybe DataCtor
-checkDataCtor2 env name c dcs d = do
- let dn = dcName d
- ctor <- Bare.failMaybe env name (Bare.resolveLocSym env name "checkDataCtor2" dn :: Either UserError Ghc.DataCon)
- let x = F.symbol ctor
- if S.member x dcs
- then Just d
- else Ex.throw (errInvalidDataCon c dn)
-
-checkDataCtor1 :: DataCtor -> DataCtor
-checkDataCtor1 d
- | x : _ <- dups = uError (err lc x :: UserError)
- | otherwise = d
- where
- lc = dcName d
- xts = dcFields d
- dups = [ x | (x, ts) <- Misc.groupList xts, 2 <= length ts ]
- err lc x = ErrDupField (GM.sourcePosSrcSpan $ loc lc) (pprint $ val lc) (pprint x)
-
-
-
-selectDD :: (a, [DataDecl]) -> Either [DataDecl] DataDecl
-selectDD (_,[d]) = Right d
-selectDD (_, ds) = case [ d | d <- ds, tycKind d == DataReflected ] of
- [d] -> Right d
- _ -> Left ds
-
-groupVariances :: [DataDecl]
- -> [(LocSymbol, [Variance])]
- -> [(Maybe DataDecl, Maybe (LocSymbol, [Variance]))]
-groupVariances dcs vdcs = merge (L.sort dcs) (L.sortBy (\x y -> compare (fst x) (fst y)) vdcs)
- where
- merge (d:ds) (v:vs)
- | F.symbol d == sym v = (Just d, Just v) : merge ds vs
- | F.symbol d < sym v = (Just d, Nothing) : merge ds (v:vs)
- | otherwise = (Nothing, Just v) : merge (d:ds) vs
- merge [] vs = ((Nothing,) . Just) <$> vs
- merge ds [] = ((,Nothing) . Just) <$> ds
- sym = val . fst
-
-
--- | 'checkDataDecl' checks that the supplied DataDecl is indeed a refinement
--- of the GHC TyCon. We just check that the right tyvars are supplied
--- as errors in the names and types of the constructors will be caught
--- elsewhere. [e.g. tests/errors/BadDataDecl.hs]
-
-checkDataDecl :: Ghc.TyCon -> DataDecl -> Bool
-checkDataDecl c d = F.notracepp _msg (isGADT || cN == dN || null (tycDCons d))
- where
- _msg = printf "checkDataDecl: D = %s, c = %s, cN = %d, dN = %d" (show d) (show c) cN dN
- cN = length (GM.tyConTyVarsDef c)
- dN = length (tycTyVars d)
- isGADT = Ghc.isGadtSyntaxTyCon c
-
-getDnTyCon :: Bare.Env -> ModName -> DataName -> Ghc.TyCon
-getDnTyCon env name dn = Mb.fromMaybe ugh (Bare.lookupGhcDnTyCon env name "ofBDataDecl-1" dn)
- where
- ugh = impossible Nothing "getDnTyCon"
-
--- FIXME: ES: why the maybes?
-ofBDataDecl :: Bare.Env -> ModName -> Maybe DataDecl -> (Maybe (LocSymbol, [Variance]))
- -> ( (ModName, TyConP, Maybe DataPropDecl), [Located DataConP])
-ofBDataDecl env name (Just dd@(DataDecl tc as ps cts pos sfun pt _)) maybe_invariance_info
- | not (checkDataDecl tc' dd)
- = uError err
- | otherwise
- = ((name, tcp, Just (dd { tycDCons = cts }, pd)), Loc lc lc' <$> cts')
- where
- πs = Bare.ofBPVar env name pos <$> ps
- tc' = getDnTyCon env name tc
- -- cts = checkDataCtors env name tc' cts0
- cts' = ofBDataCtor env name lc lc' tc' αs ps πs <$> cts
- pd = Bare.ofBareType env name lc (Just []) <$> pt
- tys = [t | dcp <- cts', (_, t) <- dcpTyArgs dcp]
- initmap = zip (RT.uPVar <$> πs) [0..]
- varInfo = L.nub $ concatMap (getPsSig initmap True) tys
- defPs = varSignToVariance varInfo <$> [0 .. (length πs - 1)]
- (tvi, pvi) = f defPs
- tcp = TyConP lc tc' αs πs tvi pvi sfun
- err = ErrBadData (GM.fSrcSpan tc) (pprint tc) "Mismatch in number of type variables" :: UserError
- αs = RTV . GM.symbolTyVar <$> as
- n = length αs
- Loc lc lc' _ = dataNameSymbol tc
- f defPs = case maybe_invariance_info of
- Nothing -> ([], defPs)
- Just (_,is) -> (take n is, if null (drop n is) then defPs else (drop n is))
-
-ofBDataDecl env name Nothing (Just (tc, is))
- = ((name, TyConP srcpos tc' [] [] tcov tcontr Nothing, Nothing), [])
- where
- tc' = Bare.lookupGhcTyCon env name "ofBDataDecl-2" tc
- (tcov, tcontr) = (is, [])
- srcpos = F.dummyPos "LH.DataType.Variance"
-
-ofBDataDecl _ _ Nothing Nothing
- = panic Nothing "Bare.DataType.ofBDataDecl called on invalid inputs"
-
--- TODO:EFFECTS:ofBDataCon
-ofBDataCtor :: Bare.Env
- -> ModName
- -> F.SourcePos
- -> F.SourcePos
- -> Ghc.TyCon
- -> [RTyVar]
- -> [PVar BSort]
- -> [PVar RSort]
- -> DataCtor
- -> DataConP
-ofBDataCtor env name l l' tc αs ps πs _ctor@(DataCtor c as _ xts res) = DataConP
- { dcpLoc = l
- , dcpCon = c'
- , dcpFreeTyVars = RT.symbolRTyVar <$> as
- , dcpFreePred = πs
- , dcpTyConstrs = cs
- , dcpTyArgs = zts
- , dcpTyRes = ot
- , dcpIsGadt = isGadt
- , dcpModule = F.symbol name
- , dcpLocE = l'
- }
- where
- c' = Bare.lookupGhcDataCon env name "ofBDataCtor" c
- ts' = 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')
- 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
- t0 = case RT.famInstTyConType tc of
- Nothing -> F.notracepp "dataConResult-3: " $ RT.gApp tc αs πs
- Just ty -> RT.ofType ty
- isGadt = Mb.isJust res
- dLoc = F.Loc l l' ()
-
-
-
-
-errInvalidDataCon :: Ghc.TyCon -> LocSymbol -> UserError
-errInvalidDataCon c d = ErrBadGADT sp v msg
- where
- v = pprint (val d)
- sp = GM.sourcePosSrcSpan (loc d)
- msg = ppTicks c <+> "is not the type constructed by" <+> ppTicks v
-
-varSignToVariance :: Eq a => [(a, Bool)] -> a -> Variance
-varSignToVariance varsigns i = case filter (\p -> fst p == i) varsigns of
- [] -> Invariant
- [(_, b)] -> if b then Covariant else Contravariant
- _ -> Bivariant
-
-getPsSig :: [(UsedPVar, a)] -> Bool -> SpecType -> [(a, Bool)]
-getPsSig m pos (RAllT _ t r)
- = addps m pos r ++ getPsSig m pos t
-getPsSig m pos (RApp _ ts rs r)
- = addps m pos r ++ concatMap (getPsSig m pos) ts
- ++ concatMap (getPsSigPs m pos) rs
-getPsSig m pos (RVar _ r)
- = addps m pos r
-getPsSig m pos (RAppTy t1 t2 r)
- = addps m pos r ++ getPsSig m pos t1 ++ getPsSig m pos t2
-getPsSig m pos (RFun _ t1 t2 r)
- = addps m pos r ++ getPsSig m pos t2 ++ getPsSig m (not pos) t1
-getPsSig m pos (RHole r)
- = addps m pos r
-getPsSig _ _ z
- = panic Nothing $ "getPsSig" ++ show z
-
-getPsSigPs :: [(UsedPVar, a)] -> Bool -> SpecProp -> [(a, Bool)]
-getPsSigPs m pos (RProp _ (RHole r)) = addps m pos r
-getPsSigPs m pos (RProp _ t) = getPsSig m pos t
-
-addps :: [(UsedPVar, a)] -> b -> UReft t -> [(a, b)]
-addps m pos (MkUReft _ ps) = (flip (,)) pos . f <$> pvars ps
- where
- f = Mb.fromMaybe (panic Nothing "Bare.addPs: notfound") . (`L.lookup` m) . RT.uPVar
-
-keepPredType :: S.HashSet RTyVar -> SpecType -> Bool
-keepPredType tvs p
- | Just (tv, _) <- eqSubst p = S.member tv tvs
- | otherwise = True
-
-
--- | This computes the result of a `DataCon` application.
--- For 'isVanillaDataCon' we can just use the `TyCon`
--- applied to the relevant tyvars.
-dataConResultTy :: Ghc.DataCon
- -> [RTyVar] -- ^ DataConP ty-vars
- -> SpecType -- ^ vanilla result type
- -> Maybe SpecType -- ^ user-provided result type
- -> SpecType
-dataConResultTy _ _ _ (Just t) = t
-dataConResultTy c _ t _
- | Ghc.isVanillaDataCon c = F.notracepp ("dataConResultTy-1 : " ++ F.showpp c) $ t
- | otherwise = F.notracepp ("dataConResultTy-2 : " ++ F.showpp c) $ RT.ofType ct
- where
- (_,_,_,_,_,ct) = Ghc.dataConFullSig c
- -- _tr0 = Ghc.dataConRepType c
- -- _tr1 = Ghc.varType (Ghc.dataConWorkId c)
- -- _tr2 = Ghc.varType (Ghc.dataConWrapId c)
-
-eqSubst :: SpecType -> Maybe (RTyVar, SpecType)
-eqSubst (RApp c [_, _, (RVar a _), t] _ _)
- | rtc_tc c == Ghc.eqPrimTyCon = Just (a, t)
-eqSubst _ = Nothing
-
-normalizeField :: Ghc.DataCon -> Int -> (F.Symbol, a) -> (F.Symbol, a)
-normalizeField c i (x, t)
- | isTmp x = (xi, t)
- | otherwise = (x , t)
- where
- isTmp = F.isPrefixOfSym F.tempPrefix
- xi = makeDataConSelector Nothing c i
-
--- | `qualifyDataCtor` qualfies the field names for each `DataCtor` to
--- ensure things work properly when exported.
-type CtorType = ([(F.Symbol, SpecType)], SpecType)
-
-qualifyDataCtor :: Bool -> ModName -> F.Located a -> CtorType -> CtorType
-qualifyDataCtor qualFlag name l ct@(xts, t)
- | qualFlag = (xts', t')
- | otherwise = ct
- where
- t' = F.subst su <$> t
- xts' = [ (qx, F.subst su t) | (qx, t, _) <- fields ]
- su = F.mkSubst [ (x, F.eVar qx) | (qx, _, Just x) <- fields ]
- fields = [ (qx, t, mbX) | (x, t) <- xts, let (mbX, qx) = qualifyField name (F.atLoc l x) ]
-
-qualifyField :: ModName -> LocSymbol -> (Maybe F.Symbol, F.Symbol)
-qualifyField name lx
- | needsQual = (Just x, F.notracepp msg $ qualifyModName name x)
- | otherwise = (Nothing, x)
- where
- msg = "QUALIFY-NAME: " ++ show x ++ " in module " ++ show (F.symbol name)
- x = val lx
- needsQual = not (isWiredIn lx)
-
-checkRecordSelectorSigs :: [(Ghc.Var, LocSpecType)] -> [(Ghc.Var, LocSpecType)]
-checkRecordSelectorSigs vts = [ (v, take1 v ts) | (v, ts) <- Misc.groupList vts ]
- where
- take1 v ts = case Misc.nubHashOn (showpp . val) ts of
- [t] -> t
- (t:ts) -> Ex.throw (ErrDupSpecs (GM.fSrcSpan t) (pprint v) (GM.fSrcSpan <$> ts) :: Error)
- _ -> impossible Nothing "checkRecordSelectorSigs"
-
-makeRecordSelectorSigs :: Bare.Env -> ModName -> [Located DataConP] -> [(Ghc.Var, LocSpecType)]
-makeRecordSelectorSigs env name = checkRecordSelectorSigs . concatMap makeOne
- where
- makeOne (Loc l l' dcp)
- | null fls -- 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 ]
- where
- dc = dcpCon dcp
- fls = Ghc.dataConFieldLabels dc
- fs = Bare.lookupGhcNamedVar env name . Ghc.flSelector <$> fls
- ts :: [ LocSpecType ]
- ts = [ Loc l l' (mkArrow (zip (makeRTVar <$> dcpFreeTyVars dcp) (repeat mempty)) []
- [] [(z, res, mempty)]
- (dropPreds (F.subst su t `RT.strengthen` mt)))
- | (x, t) <- reverse args -- NOTE: the reverse here is correct
- , let vv = rTypeValueVar t
- -- the measure singleton refinement, eg `v = getBar foo`
- , let mt = RT.uReft (vv, F.PAtom F.Eq (F.EVar vv) (F.EApp (F.EVar x) (F.EVar z)))
- ]
-
- 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"
- res = dropPreds (dcpTyRes dcp)
-
- -- FIXME: this is clearly imprecise, but the preds in the DataConP seem
- -- to be malformed. If we leave them in, tests/pos/kmp.hs fails with
- -- a malformed predicate application. Niki, help!!
- dropPreds = fmap (\(MkUReft r _ps) -> MkUReft r mempty)
diff --git a/src/Language/Haskell/Liquid/Bare/Expand.hs b/src/Language/Haskell/Liquid/Bare/Expand.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Expand.hs
+++ /dev/null
@@ -1,764 +0,0 @@
--- | This module has the code for applying refinement (and) type aliases
--- and the pipeline for "cooking" a @BareType@ into a @SpecType@.
--- TODO: _only_ export `makeRTEnv`, `cookSpecType` and maybe `qualifyExpand`...
-
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-
-module Language.Haskell.Liquid.Bare.Expand
- ( -- * Create alias expansion environment
- makeRTEnv
-
- -- * Expand and Qualify
- , qualifyExpand
-
- -- * Converting BareType to SpecType
- , cookSpecType
- , cookSpecTypeE
- , specExpandType
-
- -- * Re-exported for data-constructors
- , plugHoles
- ) where
-
-import Prelude hiding (error)
-import Data.Graph hiding (Graph)
-import Data.Maybe
-
-import Control.Monad.State
-import qualified Control.Exception as Ex
-import qualified Data.HashMap.Strict as M
-import qualified Data.Char as Char
-import qualified Data.List as L
-import qualified Text.Printf as Printf
-import qualified Text.PrettyPrint.HughesPJ as PJ
-
-import qualified Language.Fixpoint.Types as F
--- import qualified Language.Fixpoint.Types.Visitor as F
-import qualified Language.Fixpoint.Misc as Misc
-import Language.Fixpoint.Types (Expr(..)) -- , Symbol, symbol)
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import qualified Language.Haskell.Liquid.Types.RefType as RT
-import Language.Haskell.Liquid.Types hiding (fresh)
-import qualified Language.Haskell.Liquid.Misc as Misc
-import qualified Language.Haskell.Liquid.Measure as Ms
-import qualified Language.Haskell.Liquid.Bare.Resolve as Bare
-import qualified Language.Haskell.Liquid.Bare.Types as Bare
-import qualified Language.Haskell.Liquid.Bare.Plugged as Bare
-
---------------------------------------------------------------------------------
--- | `makeRTEnv` initializes the env needed to `expand` refinements and types,
--- that is, the below needs to be called *before* we use `Expand.expand`
---------------------------------------------------------------------------------
-makeRTEnv :: Bare.Env -> ModName -> Ms.BareSpec -> Bare.ModSpecs -> LogicMap
- -> BareRTEnv
---------------------------------------------------------------------------------
-makeRTEnv env m mySpec iSpecs lmap
- = renameRTArgs $ makeRTAliases tAs $ makeREAliases eAs
- where
- tAs = [ t | (_, s) <- specs, t <- Ms.aliases s ]
- eAs = [ specREAlias env m e | (m, s) <- specs, e <- Ms.ealiases s ]
- ++ [ specREAlias env m e | (_, xl) <- M.toList (lmSymDefs lmap)
- , let e = lmapEAlias xl ]
- specs = (m, mySpec) : M.toList iSpecs
-
--- | We apply @renameRTArgs@ *after* expanding each alias-definition, to
--- ensure that the substitutions work properly (i.e. don't miss expressions
--- hidden inside @RExprArg@ or as strange type parameters.
-renameRTArgs :: BareRTEnv -> BareRTEnv
-renameRTArgs rte = RTE
- { typeAliases = M.map (fmap ( renameTys . renameVV . renameRTVArgs)) (typeAliases rte)
- , exprAliases = M.map (fmap ( renameRTVArgs)) (exprAliases rte)
- }
-
-makeREAliases :: [Located (RTAlias F.Symbol F.Expr)] -> BareRTEnv
-makeREAliases = graphExpand buildExprEdges f mempty
- where
- f rtEnv xt = setREAlias rtEnv (expandLoc rtEnv xt)
-
-
--- | @renameTys@ ensures that @RTAlias@ type parameters have distinct names
--- to avoid variable capture e.g. as in T1556.hs
-renameTys :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType
-renameTys rt = rt { rtTArgs = ys, rtBody = subts (rtBody rt) (zip xs ys) }
- where
- xs = rtTArgs rt
- ys = (`F.suffixSymbol` rtName rt) <$> xs
- subts = foldl (flip subt)
-
-
-renameVV :: RTAlias F.Symbol BareType -> RTAlias F.Symbol BareType
-renameVV rt = rt { rtBody = RT.shiftVV (rtBody rt) (F.vv (Just 0)) }
-
--- | @renameRTVArgs@ ensures that @RTAlias@ value parameters have distinct names
--- to avoid variable capture e.g. as in tests-names-pos-Capture01.hs
-renameRTVArgs :: (F.PPrint a, F.Subable a) => RTAlias x a -> RTAlias x a
-renameRTVArgs rt = rt { rtVArgs = newArgs
- , rtBody = F.notracepp msg $ F.subst su (rtBody rt)
- }
- where
- msg = "renameRTVArgs: " ++ F.showpp su
- su = F.mkSubst (zip oldArgs (F.eVar <$> newArgs))
- newArgs = zipWith rtArg (rtVArgs rt) [0..]
- oldArgs = rtVArgs rt
- rtArg x i = F.suffixSymbol x (F.intSymbol "rta" i)
-
-makeRTAliases :: [Located (RTAlias F.Symbol BareType)] -> BareRTEnv -> BareRTEnv
-makeRTAliases lxts rte = graphExpand buildTypeEdges f rte lxts
- where
- f rtEnv xt = setRTAlias rtEnv (expandLoc rtEnv xt)
-
-specREAlias :: Bare.Env -> ModName -> Located (RTAlias F.Symbol F.Expr) -> Located (RTAlias F.Symbol F.Expr)
-specREAlias env m la = F.atLoc la $ a { rtBody = Bare.qualify env m (loc la) (rtVArgs a) (rtBody a) }
- where
- a = val la
-
---------------------------------------------------------------------------------------------------------------
-
-graphExpand :: (PPrint t)
- => (AliasTable x t -> t -> [F.Symbol]) -- ^ dependencies
- -> (thing -> Located (RTAlias x t) -> thing) -- ^ update
- -> thing -- ^ initial
- -> [Located (RTAlias x t)] -- ^ vertices
- -> thing -- ^ final
-graphExpand buildEdges expBody env lxts
- = L.foldl' expBody env (genExpandOrder table' graph)
- where
- -- xts = val <$> lxts
- table = buildAliasTable lxts
- graph = buildAliasGraph (buildEdges table) lxts
- table' = checkCyclicAliases table graph
-
-setRTAlias :: RTEnv x t -> Located (RTAlias x t) -> RTEnv x t
-setRTAlias env a = env { typeAliases = M.insert n a (typeAliases env) }
- where
- n = rtName (val a)
-
-setREAlias :: RTEnv x t -> Located (RTAlias F.Symbol F.Expr) -> RTEnv x t
-setREAlias env a = env { exprAliases = M.insert n a (exprAliases env) }
- where
- n = rtName (val a)
-
-
-
---------------------------------------------------------------------------------
-type AliasTable x t = M.HashMap F.Symbol (Located (RTAlias x t))
-
-buildAliasTable :: [Located (RTAlias x t)] -> AliasTable x t
-buildAliasTable = M.fromList . map (\rta -> (rtName (val rta), rta))
-
-fromAliasSymbol :: AliasTable x t -> F.Symbol -> Located (RTAlias x t)
-fromAliasSymbol table sym
- = fromMaybe err (M.lookup sym table)
- where
- err = panic Nothing ("fromAliasSymbol: Dangling alias symbol: " ++ show sym)
-
-type Graph t = [Node t]
-type Node t = (t, t, [t])
-
-buildAliasGraph :: (PPrint t) => (t -> [F.Symbol]) -> [Located (RTAlias x t)]
- -> Graph F.Symbol
-buildAliasGraph buildEdges = map (buildAliasNode buildEdges)
-
-buildAliasNode :: (PPrint t) => (t -> [F.Symbol]) -> Located (RTAlias x t)
- -> Node F.Symbol
-buildAliasNode f la = (rtName a, rtName a, f (rtBody a))
- where
- a = val la
-
-checkCyclicAliases :: AliasTable x t -> Graph F.Symbol -> AliasTable x t
-checkCyclicAliases table graph
- = case mapMaybe go (stronglyConnComp graph) of
- [] -> table
- sccs -> Ex.throw (cycleAliasErr table <$> sccs)
- where
- go (CyclicSCC vs) = Just vs
- go (AcyclicSCC _) = Nothing
-
-cycleAliasErr :: AliasTable x t -> [F.Symbol] -> Error
-cycleAliasErr _ [] = panic Nothing "checkCyclicAliases: No type aliases in reported cycle"
-cycleAliasErr t scc@(rta:_) = ErrAliasCycle { pos = fst (locate rta)
- , acycle = map locate scc }
- where
- locate sym = ( GM.fSrcSpan $ fromAliasSymbol t sym
- , pprint sym )
-
-
-genExpandOrder :: AliasTable x t -> Graph F.Symbol -> [Located (RTAlias x t)]
-genExpandOrder table graph
- = map (fromAliasSymbol table) symOrder
- where
- (digraph, lookupVertex, _)
- = graphFromEdges graph
- symOrder
- = map (Misc.fst3 . lookupVertex) $ reverse $ topSort digraph
-
---------------------------------------------------------------------------------
-
-ordNub :: Ord a => [a] -> [a]
-ordNub = map head . L.group . L.sort
-
-buildTypeEdges :: (F.Symbolic c) => AliasTable x t -> RType c tv r -> [F.Symbol]
-buildTypeEdges table = ordNub . go
- where
- -- go :: t -> [Symbol]
- go (RApp c ts rs _) = go_alias (F.symbol c) ++ concatMap go ts ++ concatMap go (mapMaybe go_ref rs)
- go (RImpF _ t1 t2 _) = go t1 ++ go t2
- go (RFun _ t1 t2 _) = go t1 ++ go t2
- go (RAppTy t1 t2 _) = go t1 ++ go t2
- go (RAllE _ t1 t2) = go t1 ++ go t2
- go (REx _ t1 t2) = go t1 ++ go t2
- go (RAllT _ t _) = go t
- go (RAllP _ t) = go t
- go (RVar _ _) = []
- go (RExprArg _) = []
- go (RHole _) = []
- go (RRTy env _ _ t) = concatMap (go . snd) env ++ go t
- go_alias c = [c | M.member c table]
- go_ref (RProp _ (RHole _)) = Nothing
- go_ref (RProp _ t) = Just t
-
-buildExprEdges :: M.HashMap F.Symbol a -> F.Expr -> [F.Symbol]
-buildExprEdges table = ordNub . go
- where
- go :: F.Expr -> [F.Symbol]
- go (EApp e1 e2) = go e1 ++ go e2
- go (ENeg e) = go e
- go (EBin _ e1 e2) = go e1 ++ go e2
- go (EIte _ e1 e2) = go e1 ++ go e2
- go (ECst e _) = go e
- go (ESym _) = []
- go (ECon _) = []
- go (EVar v) = go_alias v
- go (PAnd ps) = concatMap go ps
- go (POr ps) = concatMap go ps
- go (PNot p) = go p
- go (PImp p q) = go p ++ go q
- go (PIff p q) = go p ++ go q
- go (PAll _ p) = go p
- go (ELam _ e) = go e
- go (ECoerc _ _ e) = go e
- go (PAtom _ e1 e2) = go e1 ++ go e2
- go (ETApp e _) = go e
- go (ETAbs e _) = go e
- go (PKVar _ _) = []
- go (PExist _ e) = go e
- go (PGrad _ _ _ e) = go e
- go_alias f = [f | M.member f table ]
-
-
-----------------------------------------------------------------------------------
--- | Using the `BareRTEnv` to do alias-expansion
-----------------------------------------------------------------------------------
-class Expand a where
- expand :: BareRTEnv -> F.SourcePos -> a -> a
-
-----------------------------------------------------------------------------------
--- | @qualifyExpand@ first qualifies names so that we can successfully resolve
--- them during expansion.
-----------------------------------------------------------------------------------
-qualifyExpand :: (Expand a, Bare.Qualify a)
- => Bare.Env -> ModName -> BareRTEnv -> F.SourcePos -> [F.Symbol] -> a -> a
-----------------------------------------------------------------------------------
-qualifyExpand env name rtEnv l bs
- = expand rtEnv l
- . Bare.qualify env name l bs
-
-----------------------------------------------------------------------------------
-expandLoc :: (Expand a) => BareRTEnv -> Located a -> Located a
-expandLoc rtEnv lx = expand rtEnv (F.loc lx) <$> lx
-
-instance Expand Expr where
- expand = expandExpr
-
-instance Expand F.Reft where
- expand rtEnv l (F.Reft (v, ra)) = F.Reft (v, expand rtEnv l ra)
-
-instance Expand RReft where
- expand rtEnv l = fmap (expand rtEnv l)
-
-expandReft :: (Expand r) => BareRTEnv -> F.SourcePos -> RType c tv r -> RType c tv r
-expandReft rtEnv l = fmap (expand rtEnv l)
--- expandReft rtEnv l = emapReft (expand rtEnv l)
-
-
--- | @expand@ on a SpecType simply expands the refinements,
--- i.e. *does not* apply the type aliases, but just the
--- 1. predicate aliases,
--- 2. inlines,
--- 3. stuff from @LogicMap@
-
-instance Expand SpecType where
- expand = expandReft
-
--- | @expand@ on a BareType actually applies the type- and expression- aliases.
-instance Expand BareType where
- expand rtEnv l
- = expandReft rtEnv l -- apply expression aliases
- . expandBareType rtEnv l -- apply type aliases
-
-instance Expand (RTAlias F.Symbol Expr) where
- expand rtEnv l x = x { rtBody = expand rtEnv l (rtBody x) }
-
-instance Expand BareRTAlias where
- expand rtEnv l x = x { rtBody = expand rtEnv l (rtBody x) }
-
-instance Expand Body where
- expand rtEnv l (P p) = P (expand rtEnv l p)
- expand rtEnv l (E e) = E (expand rtEnv l e)
- expand rtEnv l (R x p) = R x (expand rtEnv l p)
-
-instance Expand DataCtor where
- expand rtEnv l c = c
- { dcTheta = expand rtEnv l (dcTheta c)
- , dcFields = [(x, expand rtEnv l t) | (x, t) <- dcFields c ]
- , dcResult = expand rtEnv l (dcResult c)
- }
-
-instance Expand DataDecl where
- expand rtEnv l d = d
- { tycDCons = expand rtEnv l (tycDCons d)
- , tycPropTy = expand rtEnv l (tycPropTy d)
- }
-
-instance Expand BareMeasure where
- expand rtEnv l m = m
- { msSort = expand rtEnv l (msSort m)
- , msEqns = expand rtEnv l (msEqns m)
- }
-
-instance Expand BareDef where
- expand rtEnv l d = d
- { dsort = expand rtEnv l (dsort d)
- , binds = [ (x, expand rtEnv l t) | (x, t) <- binds d]
- , body = expand rtEnv l (body d)
- }
-
-instance Expand Ms.BareSpec where
- expand = expandBareSpec
-
-instance Expand a => Expand (F.Located a) where
- expand rtEnv _ = expandLoc rtEnv
-
-instance Expand a => Expand (F.LocSymbol, a) where
- expand rtEnv l (x, y) = (x, expand rtEnv l y)
-
-instance Expand a => Expand (Maybe a) where
- expand rtEnv l = fmap (expand rtEnv l)
-
-instance Expand a => Expand [a] where
- expand rtEnv l = fmap (expand rtEnv l)
-
-instance Expand a => Expand (M.HashMap k a) where
- expand rtEnv l = fmap (expand rtEnv l)
-
-expandBareSpec :: BareRTEnv -> F.SourcePos -> Ms.BareSpec -> Ms.BareSpec
-expandBareSpec rtEnv l sp = sp
- { measures = expand rtEnv l (measures sp)
- , asmSigs = expand rtEnv l (asmSigs sp)
- , sigs = expand rtEnv l (sigs sp)
- , localSigs = expand rtEnv l (localSigs sp)
- , reflSigs = expand rtEnv l (reflSigs sp)
- , ialiases = [ (f x, f y) | (x, y) <- ialiases sp ]
- , dataDecls = expand rtEnv l (dataDecls sp)
- , newtyDecls = expand rtEnv l (newtyDecls sp)
- }
- where f = expand rtEnv l
-
-expandBareType :: BareRTEnv -> F.SourcePos -> BareType -> BareType
-expandBareType rtEnv _ = go
- where
- go (RApp c ts rs r) = case lookupRTEnv c rtEnv of
- Just rta -> expandRTAliasApp (GM.fSourcePos c) rta (go <$> ts) r
- Nothing -> RApp c (go <$> ts) (goRef <$> rs) r
- go (RAppTy t1 t2 r) = RAppTy (go t1) (go t2) r
- go (RImpF x t1 t2 r) = RImpF x (go t1) (go t2) r
- go (RFun x t1 t2 r) = RFun x (go t1) (go t2) r
- go (RAllT a t r) = RAllT a (go t) r
- go (RAllP a t) = RAllP a (go t)
- go (RAllE x t1 t2) = RAllE x (go t1) (go t2)
- go (REx x t1 t2) = REx x (go t1) (go t2)
- go (RRTy e r o t) = RRTy e r o (go t)
- go t@(RHole {}) = t
- go t@(RVar {}) = t
- go t@(RExprArg {}) = t
- goRef (RProp ss t) = RProp ss (go t)
-
-lookupRTEnv :: BTyCon -> BareRTEnv -> Maybe (Located BareRTAlias)
-lookupRTEnv c rtEnv = M.lookup (F.symbol c) (typeAliases rtEnv)
-
-expandRTAliasApp :: F.SourcePos -> Located BareRTAlias -> [BareType] -> RReft -> BareType
-expandRTAliasApp l (Loc la _ rta) args r = case isOK of
- Just e -> Ex.throw e
- Nothing -> F.subst esu . (`RT.strengthen` r) . RT.subsTyVars_meet tsu $ rtBody rta
- where
- tsu = zipWith (\α t -> (α, toRSort t, t)) αs ts
- esu = F.mkSubst $ zip (F.symbol <$> εs) es
- es = exprArg l msg <$> es0
- (ts, es0) = splitAt nαs args
- (αs, εs) = (BTV <$> rtTArgs rta, rtVArgs rta)
- targs = takeWhile (not . isRExprArg) args
- eargs = dropWhile (not . isRExprArg) args
-
- -- ERROR Checking Code
- msg = "EXPAND-RTALIAS-APP: " ++ F.showpp (rtName rta)
- nαs = length αs
- nεs = length εs
- nargs = length args
- ntargs = length targs
- neargs = length eargs
- err = errRTAliasApp l la rta
- isOK :: Maybe Error
- isOK
- | nargs /= ntargs + neargs
- = err $ PJ.hsep ["Expects", pprint nαs, "type arguments and then", pprint nεs, "expression arguments, but is given", pprint nargs]
- | nargs /= nαs + nεs
- = err $ PJ.hsep ["Expects", pprint nαs, "type arguments and " , pprint nεs, "expression arguments, but is given", pprint nargs]
- | nαs /= ntargs, not (null eargs)
- = err $ PJ.hsep ["Expects", pprint nαs, "type arguments before expression arguments"]
- | otherwise
- = Nothing
-
-isRExprArg :: RType c tv r -> Bool
-isRExprArg (RExprArg _) = True
-isRExprArg _ = False
-
-errRTAliasApp :: F.SourcePos -> F.SourcePos -> BareRTAlias -> PJ.Doc -> Maybe Error
-errRTAliasApp l la rta = Just . ErrAliasApp sp name sp'
- where
- name = pprint (rtName rta)
- sp = GM.sourcePosSrcSpan l
- sp' = GM.sourcePosSrcSpan la
-
-
-
---------------------------------------------------------------------------------
--- | exprArg converts a tyVar to an exprVar because parser cannot tell
--- this function allows us to treating (parsed) "types" as "value"
--- arguments, e.g. type Matrix a Row Col = List (List a Row) Col
--- Note that during parsing, we don't necessarily know whether a
--- string is a type or a value expression. E.g. in tests/pos/T1189.hs,
--- the string `Prop (Ev (plus n n))` where `Prop` is the alias:
--- {-@ type Prop E = {v:_ | prop v = E} @-}
--- the parser will chomp in `Ev (plus n n)` as a `BareType` and so
--- `exprArg` converts that `BareType` into an `Expr`.
---------------------------------------------------------------------------------
-exprArg :: F.SourcePos -> String -> BareType -> Expr
-exprArg l msg = F.notracepp ("exprArg: " ++ msg) . go
- where
- go :: BareType -> Expr
- go (RExprArg e) = val e
- go (RVar x _) = EVar (F.symbol x)
- go (RApp x [] [] _) = EVar (F.symbol x)
- go (RApp f ts [] _) = F.mkEApp (F.symbol <$> btc_tc f) (go <$> ts)
- go (RAppTy t1 t2 _) = F.EApp (go t1) (go t2)
- go z = panic sp $ Printf.printf "Unexpected expression parameter: %s in %s" (show z) msg
- sp = Just (GM.sourcePosSrcSpan l)
-
-
-----------------------------------------------------------------------------------------
--- | @cookSpecType@ is the central place where a @BareType@ gets processed,
--- in multiple steps, into a @SpecType@. See [NOTE:Cooking-SpecType] for
--- details of each of the individual steps.
-----------------------------------------------------------------------------------------
-cookSpecType :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType
- -> LocSpecType
-cookSpecType env sigEnv name x bt
- = either Ex.throw id (cookSpecTypeE env sigEnv name x bt)
- where
- _msg = "cookSpecType: " ++ GM.showPpr (z, Ghc.varType <$> z)
- z = Bare.plugSrc x
-
-
------------------------------------------------------------------------------------------
-cookSpecTypeE :: Bare.Env -> Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocBareType
- -> Either UserError LocSpecType
------------------------------------------------------------------------------------------
-cookSpecTypeE env sigEnv name x bt
- = id
- . fmap (plugHoles sigEnv name x)
- . fmap (fmap (addTyConInfo embs tyi))
- . fmap (Bare.txRefSort tyi embs)
- . fmap (fmap txExpToBind) -- What does this function DO
- . fmap (specExpandType rtEnv)
- . fmap (fmap (generalizeWith x))
- . fmap (maybePlug sigEnv name x)
- . fmap (Bare.qualifyTop env name l)
- . bareSpecType env name
- . bareExpandType rtEnv
- $ bt
- where
- _msg i = "cook-" ++ show i ++ " : " ++ F.showpp x
- rtEnv = Bare.sigRTEnv sigEnv
- embs = Bare.sigEmbs sigEnv
- tyi = Bare.sigTyRTyMap sigEnv
- l = F.loc bt
-
--- | We don't want to generalize type variables that maybe bound in the
--- outer scope, e.g. see tests/basic/pos/LocalPlug00.hs
-
-generalizeWith :: Bare.PlugTV Ghc.Var -> SpecType -> SpecType
-generalizeWith (Bare.HsTV v) t = generalizeVar v t
-generalizeWith Bare.RawTV t = t
-generalizeWith _ t = RT.generalize t
-
-generalizeVar :: Ghc.Var -> SpecType -> SpecType
-generalizeVar v t = mkUnivs (zip as (repeat mempty)) [] t
- where
- as = filter isGen (freeTyVars t)
- (vas,_) = Ghc.splitForAllTys (GM.expandVarType v)
- isGen (RTVar (RTV a) _) = a `elem` vas
-
--- splitForAllTys :: Type -> ([TyVar], Type)
---
--- generalize :: (Eq tv) => RType c tv r -> RType c tv r
--- generalize t = mkUnivs (freeTyVars t) [] [] t
-
-
-bareExpandType :: BareRTEnv -> LocBareType -> LocBareType
-bareExpandType = expandLoc
-
-specExpandType :: BareRTEnv -> LocSpecType -> LocSpecType
-specExpandType = expandLoc
-
-bareSpecType :: Bare.Env -> ModName -> LocBareType -> Either UserError LocSpecType
-bareSpecType env name bt = case Bare.ofBareTypeE env name (F.loc bt) Nothing (val bt) of
- Left e -> Left e
- Right t -> Right (F.atLoc bt t)
-
-maybePlug :: Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType
-maybePlug sigEnv name kx = case Bare.plugSrc kx of
- Nothing -> id
- Just _ -> plugHoles sigEnv name kx
-
-plugHoles :: Bare.SigEnv -> ModName -> Bare.PlugTV Ghc.Var -> LocSpecType -> LocSpecType
-plugHoles sigEnv name = Bare.makePluggedSig name embs tyi exports
- where
- embs = Bare.sigEmbs sigEnv
- tyi = Bare.sigTyRTyMap sigEnv
- exports = Bare.sigExports sigEnv
-
-{- [NOTE:Cooking-SpecType]
- A @SpecType@ is _raw_ when it is obtained directly from a @BareType@, i.e.
- just by replacing all the @BTyCon@ with @RTyCon@. Before it can be used
- for constraint generation, we need to _cook_ it via the following transforms:
-
- A @SigEnv@ should contain _all_ the information needed to do the below steps.
-
- - expand : resolving all type/refinement etc. aliases
- - ofType : convert BareType -> SpecType
- - plugged : filling in any remaining "holes"
- - txRefSort : filling in the abstract-refinement predicates etc. (YUCK)
- - resolve : renaming / qualifying symbols?
- - expand (again) : as the "resolve" step can rename variables to trigger more aliases (e.g. member -> Data.Set.Internal.Member -> Set_mem)
- - generalize : (universally) quantify free type variables
- - strengthen-measures : ?
- - strengthen-inline(?) : ?
-
--}
-
------------------------------------------------------------------------------------------------
--- | From BareOLD.Expand
------------------------------------------------------------------------------------------------
-
-
-{- TODO-REBARE
-instance Expand ty => Expand (Def ty ctor) where
- expand z (Def f xts c t bxts b) =
- Def f <$> expand z xts
- <*> pure c
- <*> expand z t
- <*> expand z bxts
- <*> expand z b
-
-instance Expand ty => Expand (Measure ty ctor) where
- expand z (M n t ds k) =
- M n <$> expand z t <*> expand z ds <*> pure k
-
-instance Expand DataConP where
- expand z d = do
- tyRes' <- expand z (tyRes d)
- tyConsts' <- expand z (tyConstrs d)
- tyArgs' <- expand z (tyArgs d)
- return d { tyRes = tyRes', tyConstrs = tyConsts', tyArgs = tyArgs' }
--}
-
---------------------------------------------------------------------------------
--- | @expandExpr@ applies the aliases and inlines in @BareRTEnv@ to its argument
--- @Expr@. It must first @resolve@ the symbols in the refinement to see if
--- they correspond to alias definitions. However, we ensure that we do not
--- resolve bound variables (e.g. those bound in output refinements by input
--- parameters), and we use the @bs@ parameter to pass in the bound symbols.
---------------------------------------------------------------------------------
-expandExpr :: BareRTEnv -> F.SourcePos -> Expr -> Expr
-expandExpr rtEnv l = go
- where
- go e@(EApp _ _) = expandEApp rtEnv l (F.splitEApp e)
- go (EVar x) = expandSym rtEnv l x
- go (ENeg e) = ENeg (go e)
- go (ECst e s) = ECst (go e) s
- go (PAnd ps) = PAnd (go <$> ps)
- go (POr ps) = POr (go <$> ps)
- go (PNot p) = PNot (go p)
- go (PAll xs p) = PAll xs (go p)
- go (PExist xs p) = PExist xs (go p)
- go (ELam xt e) = ELam xt (go e)
- go (ECoerc a t e) = ECoerc a t (go e)
- go (ETApp e s) = ETApp (go e) s
- go (ETAbs e s) = ETAbs (go e) s
- go (EBin op e1 e2) = EBin op (go e1) (go e2)
- go (PImp e1 e2) = PImp (go e1) (go e2)
- go (PIff e1 e2) = PIff (go e1) (go e2)
- go (PAtom b e1 e2) = PAtom b (go e1) (go e2)
- go (EIte p e1 e2) = EIte (go p)(go e1) (go e2)
- go (PGrad k su i e) = PGrad k su i (go e)
- go e@(PKVar _ _) = e
- go e@(ESym _) = e
- go e@(ECon _) = e
-
-expandSym :: BareRTEnv -> F.SourcePos -> F.Symbol -> Expr
-expandSym rtEnv l s' = expandEApp rtEnv l (EVar s', [])
-
--- REBARE :: expandSym' :: Symbol -> BareM Symbol
--- REBARE :: expandSym' s = do
- -- REBARE :: axs <- gets axSyms
- -- REBARE :: let s' = dropModuleNamesAndUnique s
- -- REBARE :: return $ if M.member s' axs then s' else s
-
-expandEApp :: BareRTEnv -> F.SourcePos -> (Expr, [Expr]) -> Expr
-expandEApp rtEnv l (EVar f, es) = case mBody of
- Just re -> expandApp l re es'
- Nothing -> F.eApps (EVar f) es'
- where
- eAs = exprAliases rtEnv
- mBody = Misc.firstMaybes [M.lookup f eAs, M.lookup (GM.dropModuleUnique f) eAs]
- es' = expandExpr rtEnv l <$> es
- _f0 = GM.dropModuleNamesAndUnique f
-
-expandEApp _ _ (f, es) = F.eApps f es
-
---------------------------------------------------------------------------------
--- | Expand Alias Application --------------------------------------------------
---------------------------------------------------------------------------------
-expandApp :: F.Subable ty => F.SourcePos -> Located (RTAlias F.Symbol ty) -> [Expr] -> ty
-expandApp l lre es
- | Just su <- args = F.subst su (rtBody re)
- | otherwise = Ex.throw err
- where
- re = F.val lre
- args = F.mkSubst <$> Misc.zipMaybe (rtVArgs re) es
- err :: UserError
- err = ErrAliasApp sp alias sp' msg
- sp = GM.sourcePosSrcSpan l
- alias = pprint (rtName re)
- sp' = GM.fSrcSpan lre -- sourcePosSrcSpan (rtPos re)
- msg = "expects" PJ.<+> pprint (length $ rtVArgs re)
- PJ.<+> "arguments but it is given"
- PJ.<+> pprint (length es)
-
-
--------------------------------------------------------------------------------
--- | Replace Predicate Arguments With Existentials ----------------------------
--------------------------------------------------------------------------------
-txExpToBind :: SpecType -> SpecType
--------------------------------------------------------------------------------
-txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs)
- where
- πs = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ]
-
-data ExSt = ExSt { fresh :: Int
- , emap :: M.HashMap F.Symbol (RSort, F.Expr)
- , pmap :: M.HashMap F.Symbol RPVar
- }
-
--- | TODO: Niki please write more documentation for this, maybe an example?
--- I can't really tell whats going on... (RJ)
-
-expToBindT :: SpecType -> State ExSt SpecType
-expToBindT (RVar v r)
- = expToBindRef r >>= addExists . RVar v
-expToBindT (RFun x t1 t2 r)
- = do t1' <- expToBindT t1
- t2' <- expToBindT t2
- expToBindRef r >>= addExists . RFun x t1' t2'
-expToBindT (RAllT a t r)
- = do t' <- expToBindT t
- expToBindRef r >>= addExists . RAllT a t'
-expToBindT (RAllP p t)
- = liftM (RAllP p) (expToBindT t)
-expToBindT (RApp c ts rs r)
- = do ts' <- mapM expToBindT ts
- rs' <- mapM expToBindReft rs
- expToBindRef r >>= addExists . RApp c ts' rs'
-expToBindT (RAppTy t1 t2 r)
- = do t1' <- expToBindT t1
- t2' <- expToBindT t2
- expToBindRef r >>= addExists . RAppTy t1' t2'
-expToBindT (RRTy xts r o t)
- = do xts' <- zip xs <$> mapM expToBindT ts
- r' <- expToBindRef r
- t' <- expToBindT t
- return $ RRTy xts' r' o t'
- where
- (xs, ts) = unzip xts
-expToBindT t
- = return t
-
-expToBindReft :: SpecProp -> State ExSt SpecProp
-expToBindReft (RProp s (RHole r)) = rPropP s <$> expToBindRef r
-expToBindReft (RProp s t) = RProp s <$> expToBindT t
-
-
-getBinds :: State ExSt (M.HashMap F.Symbol (RSort, F.Expr))
-getBinds
- = do bds <- emap <$> get
- modify $ \st -> st{emap = M.empty}
- return bds
-
-addExists :: SpecType -> State ExSt SpecType
-addExists t = liftM (M.foldlWithKey' addExist t) getBinds
-
-addExist :: SpecType -> F.Symbol -> (RSort, F.Expr) -> SpecType
-addExist t x (tx, e) = REx x t' t
- where
- t' = (ofRSort tx) `strengthen` uTop r
- r = F.exprReft e
-
-expToBindRef :: UReft r -> State ExSt (UReft r)
-expToBindRef (MkUReft r (Pr p))
- = mapM expToBind p >>= return . (MkUReft r) . Pr
-
-expToBind :: UsedPVar -> State ExSt UsedPVar
-expToBind p = do
- res <- liftM (M.lookup (pname p)) (pmap <$> get)
- case res of
- Nothing ->
- panic Nothing ("expToBind: " ++ show p)
- Just π -> do
- let pargs0 = zip (pargs p) (Misc.fst3 <$> pargs π)
- pargs' <- mapM expToBindParg pargs0
- return $ p { pargs = pargs' }
-
-expToBindParg :: (((), F.Symbol, F.Expr), RSort) -> State ExSt ((), F.Symbol, F.Expr)
-expToBindParg ((t, s, e), s') = liftM ((,,) t s) (expToBindExpr e s')
-
-expToBindExpr :: F.Expr -> RSort -> State ExSt F.Expr
-expToBindExpr e@(EVar s) _
- | Char.isLower $ F.headSym $ F.symbol s
- = return e
-expToBindExpr e t
- = do s <- freshSymbol
- modify $ \st -> st{emap = M.insert s (t, e) (emap st)}
- return $ EVar s
-
-freshSymbol :: State ExSt F.Symbol
-freshSymbol
- = do n <- fresh <$> get
- modify $ \s -> s {fresh = n+1}
- return $ F.symbol $ "ex#" ++ show n
-
diff --git a/src/Language/Haskell/Liquid/Bare/Laws.hs b/src/Language/Haskell/Liquid/Bare/Laws.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Laws.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-module Language.Haskell.Liquid.Bare.Laws ( makeInstanceLaws ) where
-
-import qualified Data.Maybe as Mb
-import qualified Data.List as L
-import qualified Data.HashMap.Strict as M
-import Control.Monad (join)
-
-import qualified Language.Haskell.Liquid.Measure as Ms
-import qualified Language.Fixpoint.Types as F
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import Language.Haskell.Liquid.Bare.Types as Bare
-import Language.Haskell.Liquid.Bare.Resolve as Bare
-import Language.Haskell.Liquid.Bare.Expand as Bare
-import Language.Haskell.Liquid.Types
-import Language.Haskell.Liquid.GHC.API
-
-
-
-makeInstanceLaws :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)]
- -> Bare.ModSpecs -> [LawInstance]
-makeInstanceLaws env sigEnv sigs specs
- = [makeInstanceLaw env sigEnv sigs name rilaw
- | (name, spec) <- M.toList specs
- , rilaw <- Ms.ilaws spec ]
-
-
-makeInstanceLaw :: Bare.Env -> Bare.SigEnv -> [(Var,LocSpecType)] -> ModName
- -> RILaws LocBareType -> LawInstance
-makeInstanceLaw env sigEnv sigs name rilaw = LawInstance
- { lilName = Mb.fromMaybe errmsg tc
- , liSupers = mkTy <$> rilSupers rilaw
- , lilTyArgs = mkTy <$> rilTyArgs rilaw
- , lilEqus = [(mkVar l, mkTypedVar r) | (l,r)<- rilEqus rilaw ]
- , lilPos = GM.sourcePosSrcSpan $ loc $ rilPos rilaw
- }
- where
- tc :: Maybe Class
- tc = classTc (rilName rilaw)
- errmsg = error ("Not a type class: " ++ F.showpp tc)
-
- classTc = join . fmap tyConClass_maybe . Bare.maybeResolveSym env name "makeClass" . btc_tc
-
- mkTy :: LocBareType -> LocSpecType
- mkTy = Bare.cookSpecType env sigEnv name Bare.GenTV
- mkVar :: LocSymbol -> VarOrLocSymbol
- mkVar x = case Bare.maybeResolveSym env name "makeInstanceLaw" x of
- Just v -> Left v
- _ -> Right x
-
- mkTypedVar :: LocSymbol -> (VarOrLocSymbol, Maybe LocSpecType)
- mkTypedVar l = case mkVar l of
- Left x -> (Left x, Just $ Mb.fromMaybe (dummyLoc $ ofType $ varType x) (L.lookup x sigs))
- Right x -> (Right x, Nothing)
-
diff --git a/src/Language/Haskell/Liquid/Bare/Measure.hs b/src/Language/Haskell/Liquid/Bare/Measure.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Measure.hs
+++ /dev/null
@@ -1,492 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
-
--- | This module contains (most of) the code needed to lift Haskell entitites,
--- . code- (CoreBind), and data- (Tycon) definitions into the spec level.
-
-module Language.Haskell.Liquid.Bare.Measure
- ( makeHaskellMeasures
- , makeHaskellInlines
- , makeHaskellDataDecls
- , makeMeasureSelectors
- , makeMeasureSpec
- , makeMeasureSpec'
- , varMeasures
- , makeClassMeasureSpec
- -- , makeHaskellBounds
- ) where
-
-import Data.Default
-import qualified Control.Exception as Ex
-import Prelude hiding (mapM, error)
-import Data.Bifunctor
-import qualified Data.Maybe as Mb
-import Text.PrettyPrint.HughesPJ (text)
--- import Text.Printf (printf)
-
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-
-import Language.Fixpoint.SortCheck (isFirstOrder)
-import qualified Language.Fixpoint.Types as F
-import Language.Haskell.Liquid.Transforms.CoreToLogic
-import qualified Language.Fixpoint.Misc as Misc
-import qualified Language.Haskell.Liquid.Misc as Misc
-import Language.Haskell.Liquid.Misc ((.||.))
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import qualified Language.Haskell.Liquid.Types.RefType as RT
-import Language.Haskell.Liquid.Types
--- import Language.Haskell.Liquid.Types.Bounds
-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.Expand as Bare
-import qualified Language.Haskell.Liquid.Bare.DataType as Bare
-import qualified Language.Haskell.Liquid.Bare.ToBare as Bare
-
---------------------------------------------------------------------------------
-makeHaskellMeasures :: GhcSrc -> Bare.TycEnv -> LogicMap -> Ms.BareSpec
- -> [Measure (Located BareType) LocSymbol]
---------------------------------------------------------------------------------
-makeHaskellMeasures src tycEnv lmap spec
- = Bare.measureToBare <$> ms
- where
- ms = makeMeasureDefinition tycEnv lmap cbs <$> mSyms
- cbs = nonRecCoreBinds (_giCbs src)
- mSyms = S.toList (Ms.hmeas spec)
-
-makeMeasureDefinition :: Bare.TycEnv -> LogicMap -> [Ghc.CoreBind] -> LocSymbol
- -> Measure LocSpecType Ghc.DataCon
-makeMeasureDefinition tycEnv lmap cbs x =
- case GM.findVarDef (val x) cbs of
- Nothing -> Ex.throw $ errHMeas x "Cannot extract measure from haskell function"
- Just (v, def) -> Ms.mkM vx vinfo mdef MsLifted (makeUnSorted (Ghc.varType v) mdef)
- where
- vx = F.atLoc x (F.symbol v)
- mdef = coreToDef' tycEnv lmap vx v def
- vinfo = GM.varLocInfo logicType v
-
-makeUnSorted :: Ghc.Type -> [Def LocSpecType Ghc.DataCon] -> UnSortedExprs
-makeUnSorted t defs
- | isMeasureType ta
- = mempty
- | otherwise
- = map defToUnSortedExpr defs
- where
- ta = go $ Ghc.expandTypeSynonyms t
-
- go (Ghc.ForAllTy _ t) = go t
- go (Ghc.FunTy { Ghc.ft_arg = p, Ghc.ft_res = t}) | Ghc.isClassPred p = go t
- go (Ghc.FunTy { Ghc.ft_arg = t }) = t
- go t = t -- this should never happen!
-
- isMeasureType (Ghc.TyConApp _ ts) = all Ghc.isTyVarTy ts
- isMeasureType _ = False
-
- defToUnSortedExpr def = (xx:(fst <$> binds def),
- Ms.bodyPred (F.mkEApp (measure def) [F.expr xx]) (body def))
-
- xx = F.vv $ Just 10000
-
-coreToDef' :: Bare.TycEnv -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr
- -> [Def LocSpecType Ghc.DataCon]
-coreToDef' tycEnv lmap vx v def =
- case runToLogic embs lmap dm (errHMeas vx) (coreToDef vx v def) of
- Right l -> l
- Left e -> Ex.throw e
- where
- embs = Bare.tcEmbs tycEnv
- dm = Bare.tcDataConMap tycEnv
-
-errHMeas :: LocSymbol -> String -> Error
-errHMeas x str = ErrHMeas (GM.sourcePosSrcSpan $ loc x) (pprint $ val x) (text str)
-
---------------------------------------------------------------------------------
-makeHaskellInlines :: GhcSrc -> F.TCEmb Ghc.TyCon -> LogicMap -> Ms.BareSpec
- -> [(LocSymbol, LMap)]
---------------------------------------------------------------------------------
-makeHaskellInlines src embs lmap spec
- = makeMeasureInline embs lmap cbs <$> inls
- where
- cbs = nonRecCoreBinds (_giCbs src)
- inls = S.toList (Ms.inlines spec)
-
-makeMeasureInline :: F.TCEmb Ghc.TyCon -> LogicMap -> [Ghc.CoreBind] -> LocSymbol
- -> (LocSymbol, LMap)
-makeMeasureInline embs lmap cbs x =
- case GM.findVarDef (val x) cbs of
- Nothing -> Ex.throw $ errHMeas x "Cannot inline haskell function"
- Just (v, def) -> (vx, coreToFun' embs Nothing lmap vx v def ok)
- where
- vx = F.atLoc x (F.symbol v)
- ok (xs, e) = LMap vx (F.symbol <$> xs) (either id id e)
-
--- | @coreToFun'@ takes a @Maybe DataConMap@: we need a proper map when lifting
--- measures and reflects (which have case-of, and hence, need the projection symbols),
--- but NOT when lifting inlines (which do not have case-of).
--- For details, see [NOTE:Lifting-Stages]
-
-coreToFun' :: F.TCEmb Ghc.TyCon -> Maybe Bare.DataConMap -> LogicMap -> LocSymbol -> Ghc.Var -> Ghc.CoreExpr
- -> (([Ghc.Var], Either F.Expr F.Expr) -> a) -> a
-coreToFun' embs dmMb lmap x v def ok = either Ex.throw ok act
- where
- act = runToLogic embs lmap dm err xFun
- xFun = coreToFun x v def
- err = errHMeas x
- dm = Mb.fromMaybe mempty dmMb
-
-
-nonRecCoreBinds :: [Ghc.CoreBind] -> [Ghc.CoreBind]
-nonRecCoreBinds = concatMap go
- where
- go cb@(Ghc.NonRec _ _) = [cb]
- go (Ghc.Rec xes) = [Ghc.NonRec x e | (x, e) <- xes]
-
--------------------------------------------------------------------------------
-makeHaskellDataDecls :: Config -> ModName -> Ms.BareSpec -> [Ghc.TyCon]
- -> [DataDecl]
---------------------------------------------------------------------------------
-makeHaskellDataDecls cfg name spec tcs
- | exactDCFlag cfg = Mb.mapMaybe tyConDataDecl
- -- . F.tracepp "makeHaskellDataDecls-3"
- . zipMap (hasDataDecl name spec . fst)
- -- . F.tracepp "makeHaskellDataDecls-2"
- . liftableTyCons
- -- . F.tracepp "makeHaskellDataDecls-1"
- . filter isReflectableTyCon
- $ tcs
- | otherwise = []
-
-
-isReflectableTyCon :: Ghc.TyCon -> Bool
-isReflectableTyCon = Ghc.isFamInstTyCon .||. Ghc.isVanillaAlgTyCon
-
-liftableTyCons :: [Ghc.TyCon] -> [(Ghc.TyCon, DataName)]
-liftableTyCons
- = F.notracepp "LiftableTCs 3"
- . zipMapMaybe (tyConDataName True)
- . F.notracepp "LiftableTCs 2"
- . filter (not . Ghc.isBoxedTupleTyCon)
- . F.notracepp "LiftableTCs 1"
- -- . (`sortDiff` wiredInTyCons)
- -- . F.tracepp "LiftableTCs 0"
-
-zipMap :: (a -> b) -> [a] -> [(a, b)]
-zipMap f xs = zip xs (map f xs)
-
-zipMapMaybe :: (a -> Maybe b) -> [a] -> [(a, b)]
-zipMapMaybe f = Mb.mapMaybe (\x -> (x, ) <$> f x)
-
-hasDataDecl :: ModName -> Ms.BareSpec -> Ghc.TyCon -> HasDataDecl
-hasDataDecl mod spec
- = \tc -> F.notracepp (msg tc) $ M.lookupDefault def (tcName tc) decls
- where
- msg tc = "hasDataDecl " ++ show (tcName tc)
- def = NoDecl Nothing
- tcName = fmap (qualifiedDataName mod) . tyConDataName True
- dcName = qualifiedDataName mod . tycName
- decls = M.fromList [ (Just dn, hasDecl d)
- | d <- Ms.dataDecls spec
- , let dn = dcName d]
-
-qualifiedDataName :: ModName -> DataName -> DataName
-qualifiedDataName mod (DnName lx) = DnName (qualifyModName mod <$> lx)
-qualifiedDataName mod (DnCon lx) = DnCon (qualifyModName mod <$> lx)
-
-{-tyConDataDecl :: {tc:TyCon | isAlgTyCon tc} -> Maybe DataDecl @-}
-tyConDataDecl :: ((Ghc.TyCon, DataName), HasDataDecl) -> Maybe DataDecl
-tyConDataDecl (_, HasDecl)
- = Nothing
-tyConDataDecl ((tc, dn), NoDecl szF)
- = Just $ DataDecl
- { tycName = dn
- , tycTyVars = F.symbol <$> GM.tyConTyVarsDef tc
- , tycPVars = []
- , tycDCons = decls tc
- , tycSrcPos = GM.getSourcePos tc
- , tycSFun = szF
- , tycPropTy = Nothing
- , tycKind = DataReflected
- }
- where decls = map dataConDecl . Ghc.tyConDataCons
-
-tyConDataName :: Bool -> Ghc.TyCon -> Maybe DataName
-tyConDataName full tc
- | vanillaTc = Just (DnName ((post . F.symbol) <$> GM.locNamedThing tc))
- | d:_ <- dcs = Just (DnCon ((post . F.symbol) <$> GM.locNamedThing d ))
- | otherwise = Nothing
- where
- post = if full then id else GM.dropModuleNamesAndUnique
- vanillaTc = Ghc.isVanillaAlgTyCon tc
- dcs = Misc.sortOn F.symbol (Ghc.tyConDataCons tc)
-
-dataConDecl :: Ghc.DataCon -> DataCtor
-dataConDecl d = {- F.notracepp msg $ -} DataCtor dx (F.symbol <$> as) [] xts outT
- where
- isGadt = not (Ghc.isVanillaDataCon d)
- -- msg = printf "dataConDecl (gadt = %s)" (show isGadt)
- xts = [(Bare.makeDataConSelector Nothing d i, RT.bareOfType t) | (i, t) <- its ]
- dx = F.symbol <$> GM.locNamedThing d
- its = zip [1..] ts
- (as,_ps,ts,t) = Ghc.dataConSig d
- outT = Just (RT.bareOfType t :: BareType)
- _outT :: Maybe BareType
- _outT
- | isGadt = Just (RT.bareOfType t)
- | otherwise = Nothing
-
-
-
-
-
---------------------------------------------------------------------------------
--- | 'makeMeasureSelectors' converts the 'DataCon's and creates the measures for
--- the selectors and checkers that then enable reflection.
---------------------------------------------------------------------------------
-
-makeMeasureSelectors :: Config -> Bare.DataConMap -> Located DataConP -> [Measure SpecType Ghc.DataCon]
-makeMeasureSelectors cfg dm (Loc l l' c)
- = (Misc.condNull (exactDCFlag cfg) $ checker : Mb.catMaybes (go' <$> fields)) -- internal measures, needed for reflection
- ++ (Misc.condNull (autofields) $ Mb.catMaybes (go <$> fields)) -- user-visible measures.
- where
- dc = dcpCon c
- isGadt = dcpIsGadt c
- xts = dcpTyArgs c
- autofields = not (isGadt)
- go ((x, t), i)
- -- do not make selectors for functional fields
- | isFunTy t && not (higherOrderFlag cfg)
- = Nothing
- | otherwise
- = Just $ makeMeasureSelector (Loc l l' x) (projT i) dc n i
-
- go' ((_,t), i)
- -- do not make selectors for functional fields
- | isFunTy t && not (higherOrderFlag cfg)
- = Nothing
- | otherwise
- = Just $ makeMeasureSelector (Loc l l' (Bare.makeDataConSelector (Just dm) dc i)) (projT i) dc n i
-
- fields = zip (reverse xts) [1..]
- n = length xts
- checker = makeMeasureChecker (Loc l l' (Bare.makeDataConChecker dc)) checkT dc n
- projT i = dataConSel dc n (Proj i)
- checkT = dataConSel dc n Check
-
-dataConSel :: Ghc.DataCon -> Int -> DataConSel -> SpecType
-dataConSel dc n Check = mkArrow (zip as (repeat mempty)) [] [] [xt] bareBool
- where
- (as, _, xt) = {- traceShow ("dataConSel: " ++ show dc) $ -} bkDataCon dc n
-
-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
- err = panic Nothing $ "DataCon " ++ show dc ++ "does not have " ++ show i ++ " fields"
-
--- bkDataCon :: DataCon -> Int -> ([RTVar RTyVar RSort], [SpecType], (Symbol, SpecType, RReft))
-bkDataCon :: (F.Reftable (RTProp RTyCon RTyVar r), PPrint r, F.Reftable r) => Ghc.DataCon -> Int -> ([RTVar RTyVar RSort], [RRType r], (F.Symbol, RRType r, r))
-bkDataCon dc nFlds = (as, ts, (F.dummySymbol, t, mempty))
- where
- ts = RT.ofType <$> Misc.takeLast nFlds _ts
- t = -- Misc.traceShow ("bkDataConResult" ++ GM.showPpr (dc, _t, _t0)) $
- RT.ofType $ Ghc.mkTyConApp tc tArgs'
- as = makeRTVar . RT.rTyVar <$> (αs ++ αs')
- ((αs,αs',_,_,_ts,_t), _t0) = hammer dc
- tArgs' = take (nArgs - nVars) tArgs ++ (Ghc.mkTyVarTy <$> αs)
- nVars = length αs
- nArgs = length tArgs
- (tc, tArgs) = Mb.fromMaybe err (Ghc.splitTyConApp_maybe _t)
- err = GM.namedPanic dc ("Cannot split result type of DataCon " ++ show dc)
- hammer dc = (Ghc.dataConFullSig dc, Ghc.varType . Ghc.dataConWorkId $ dc)
-
-data DataConSel = Check | Proj Int
-
-bareBool :: SpecType
-bareBool = RApp (RTyCon Ghc.boolTyCon [] def) [] [] mempty
-
-
-{- | NOTE:Use DataconWorkId
-
- dcWorkId :: forall a1 ... aN. (a1 ~ X1 ...) => T1 -> ... -> Tn -> T
- checkT :: forall as. T -> Bool
- projT t :: forall as. T -> t
-
--}
-
-makeMeasureSelector :: (Show a1) => LocSymbol -> SpecType -> Ghc.DataCon -> Int -> a1 -> Measure SpecType Ghc.DataCon
-makeMeasureSelector x s dc n i = M { msName = x, msSort = s, msEqns = [eqn], msKind = MsSelector, msUnSorted = mempty}
- where
- eqn = Def x dc Nothing args (E (F.EVar $ mkx i))
- args = ((, Nothing) . mkx) <$> [1 .. n]
- mkx j = F.symbol ("xx" ++ show j)
-
-makeMeasureChecker :: LocSymbol -> SpecType -> Ghc.DataCon -> Int -> Measure SpecType Ghc.DataCon
-makeMeasureChecker x s0 dc n = M { msName = x, msSort = s, msEqns = eqn : (eqns <$> filter (/= dc) dcs), msKind = MsChecker, msUnSorted = mempty }
- where
- s = F.notracepp ("makeMeasureChecker: " ++ show x) s0
- eqn = Def x dc Nothing (((, Nothing) . mkx) <$> [1 .. n]) (P F.PTrue)
- eqns d = Def x d Nothing (((, Nothing) . mkx) <$> [1 .. nArgs d]) (P F.PFalse)
- nArgs d = length (Ghc.dataConOrigArgTys d)
- mkx j = F.symbol ("xx" ++ show j)
- dcs = Ghc.tyConDataCons (Ghc.dataConTyCon dc)
-
-
-----------------------------------------------------------------------------------------------
-makeMeasureSpec' :: MSpec SpecType Ghc.DataCon -> ([(Ghc.Var, SpecType)], [(LocSymbol, RRType F.Reft)])
-----------------------------------------------------------------------------------------------
-makeMeasureSpec' mspec0 = (ctorTys, measTys)
- where
- ctorTys = Misc.mapSnd RT.uRType <$> ctorTys0
- (ctorTys0, measTys) = Ms.dataConTypes mspec
- mspec = first (mapReft ur_reft) mspec0
-
-----------------------------------------------------------------------------------------------
-makeMeasureSpec :: Bare.Env -> Bare.SigEnv -> ModName -> (ModName, Ms.BareSpec) -> Ms.MSpec SpecType Ghc.DataCon
-----------------------------------------------------------------------------------------------
-makeMeasureSpec env sigEnv myName (name, spec)
- = mkMeasureDCon env name
- . mkMeasureSort env name
- . first val
- . bareMSpec env sigEnv myName name
- $ spec
-
-bareMSpec :: Bare.Env -> Bare.SigEnv -> ModName -> ModName -> Ms.BareSpec -> Ms.MSpec LocBareType LocSymbol
-bareMSpec env sigEnv myName name spec = Ms.mkMSpec ms cms ims
- where
- cms = F.notracepp "CMS" $ filter inScope1 $ Ms.cmeasures spec
- ms = F.notracepp "UMS" $ filter inScope2 $ expMeas <$> Ms.measures spec
- ims = F.notracepp "IMS" $ filter inScope2 $ expMeas <$> Ms.imeasures spec
- expMeas = expandMeasure env name rtEnv
- rtEnv = Bare.sigRTEnv sigEnv
- force = name == myName
- inScope1 z = F.notracepp ("inScope1: " ++ F.showpp (msName z)) $ (force || okSort z)
- inScope2 z = F.notracepp ("inScope2: " ++ F.showpp (msName z)) $ (force || (okSort z && okCtors z))
- okSort = Bare.knownGhcType env name . msSort
- okCtors = all (Bare.knownGhcDataCon env name . ctor) . msEqns
-
-mkMeasureDCon :: Bare.Env -> ModName -> Ms.MSpec t LocSymbol -> Ms.MSpec t Ghc.DataCon
-mkMeasureDCon env name m = mkMeasureDCon_ m [ (val n, symDC n) | n <- measureCtors m ]
- where
- symDC = Bare.lookupGhcDataCon env name "measure-datacon"
-
-mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(F.Symbol, Ghc.DataCon)] -> Ms.MSpec t Ghc.DataCon
-mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'}
- where
- m' = fmap (tx.val) m
- cm' = Misc.hashMapMapKeys (F.symbol . tx) $ Ms.ctorMap m'
- tx = Misc.mlookup (M.fromList ndcs)
-
-measureCtors :: Ms.MSpec t LocSymbol -> [LocSymbol]
-measureCtors = Misc.sortNub . fmap ctor . concat . M.elems . Ms.ctorMap
-
-mkMeasureSort :: Bare.Env -> ModName -> Ms.MSpec BareType LocSymbol
- -> Ms.MSpec SpecType LocSymbol
-mkMeasureSort env name (Ms.MSpec c mm cm im) =
- Ms.MSpec (map txDef <$> c) (tx <$> mm) (tx <$> cm) (tx <$> im)
- where
- ofMeaSort :: F.SourcePos -> BareType -> SpecType
- ofMeaSort l = Bare.ofBareType env name l Nothing
-
- tx :: Measure BareType ctor -> (Measure SpecType ctor)
- tx (M n s eqs k u) = M n (ofMeaSort l s) (txDef <$> eqs) k u where l = GM.fSourcePos n
-
- txDef :: Def BareType ctor -> (Def SpecType ctor)
- txDef d = first (ofMeaSort l) d where l = GM.fSourcePos (measure d)
-
-
-
---------------------------------------------------------------------------------
--- | Expand Measures -----------------------------------------------------------
---------------------------------------------------------------------------------
--- type BareMeasure = Measure LocBareType LocSymbol
-
-expandMeasure :: Bare.Env -> ModName -> BareRTEnv -> BareMeasure -> BareMeasure
-expandMeasure env name rtEnv m = m
- { msSort = RT.generalize <$> msSort m
- , msEqns = expandMeasureDef env name rtEnv <$> msEqns m
- }
-
-expandMeasureDef :: Bare.Env -> ModName -> BareRTEnv -> Def t LocSymbol -> Def t LocSymbol
-expandMeasureDef env name rtEnv d = d
- { body = F.notracepp msg $ Bare.qualifyExpand env name rtEnv l bs (body d) }
- where
- l = loc (measure d)
- bs = fst <$> binds d
- msg = "QUALIFY-EXPAND-BODY" ++ F.showpp (bs, body d)
-
-------------------------------------------------------------------------------
-varMeasures :: (Monoid r) => Bare.Env -> [(F.Symbol, Located (RRType r))]
-------------------------------------------------------------------------------
-varMeasures env =
- [ (F.symbol v, varSpecType v)
- | v <- knownVars env
- , GM.isDataConId v
- , isSimpleType (Ghc.varType v) ]
-
-knownVars :: Bare.Env -> [Ghc.Var]
-knownVars env = [ v | (_, xThings) <- M.toList (Bare._reTyThings env)
- , (_,Ghc.AnId v) <- xThings
- ]
-
-varSpecType :: (Monoid r) => Ghc.Var -> Located (RRType r)
-varSpecType = fmap (RT.ofType . Ghc.varType) . GM.locNamedThing
-
-isSimpleType :: Ghc.Type -> Bool
-isSimpleType = isFirstOrder . RT.typeSort mempty
-
-makeClassMeasureSpec :: MSpec (RType c tv (UReft r2)) t
- -> [(LocSymbol, CMeasure (RType c tv r2))]
-makeClassMeasureSpec (Ms.MSpec {..}) = tx <$> M.elems cmeasMap
- where
- tx (M n s _ _ _) = (n, CM n (mapReft ur_reft s))
-
-
-{-
-expandMeasureBody :: Bare.Env -> ModName -> BareRTEnv -> SourcePos -> Body -> Body
-expandMeasureBody env name rtEnv l (P p) = P (Bare.expandQualify env name rtEnv l p)
-expandMeasureBody env name rtEnv l (R x p) = R x (Bare.expandQualify env name rtEnv l p)
-expandMeasureBody env name rtEnv l (E e) = E (Bare.expandQualify env name rtEnv l e)
-
-
-makeHaskellBounds :: F.TCEmb TyCon -> CoreProgram -> S.HashSet (Var, LocSymbol) -> BareM RBEnv -- TODO-REBARE
-makeHaskellBounds embs cbs xs = do
- lmap <- gets logicEnv
- M.fromList <$> mapM (makeHaskellBound embs lmap cbs) (S.toList xs)
-
-makeHaskellBound :: F.TCEmb TyCon
- -> LogicMap
- -> [Bind Var]
- -> (Var, Located Symbol)
- -> BareM (LocSymbol, RBound)
-makeHaskellBound embs lmap cbs (v, x) =
- case filter ((v `elem`) . GM.binders) cbs of
- (NonRec v def:_) -> toBound v x <$> coreToFun' embs lmap x v def return
- (Rec [(v, def)]:_) -> toBound v x <$> coreToFun' embs lmap x v def return
- _ -> throwError $ errHMeas x "Cannot make bound of haskell function"
-
-
-
-toBound :: Var -> LocSymbol -> ([Var], Either F.Expr F.Expr) -> (LocSymbol, RBound)
-toBound v x (vs, Left p) = (x', Bound x' fvs ps xs p)
- where
- x' = capitalizeBound x
- (ps', xs') = L.partition (hasBoolResult . varType) vs
- (ps , xs) = (txp <$> ps', txx <$> xs')
- txp v = (dummyLoc $ simpleSymbolVar v, RT.ofType $ varType v)
- txx v = (dummyLoc $ symbol v, RT.ofType $ varType v)
- fvs = (((`RVar` mempty) . RTV) <$> fst (splitForAllTys $ varType v)) :: [RSort]
-
-toBound v x (vs, Right e) = toBound v x (vs, Left e)
-
-capitalizeBound :: Located Symbol -> Located Symbol
-capitalizeBound = fmap (symbol . toUpperHead . symbolString)
- where
- toUpperHead [] = []
- toUpperHead (x:xs) = toUpper x:xs
-
--}
-
diff --git a/src/Language/Haskell/Liquid/Bare/Misc.hs b/src/Language/Haskell/Liquid/Bare/Misc.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Misc.hs
+++ /dev/null
@@ -1,184 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-
-module Language.Haskell.Liquid.Bare.Misc
- ( freeSymbols
- , joinVar
- , mkVarExpr
- , vmap
- , runMapTyVars
- , matchKindArgs
- , symbolRTyVar
- , simpleSymbolVar
- , hasBoolResult
- , isKind
- ) where
-
-import Prelude hiding (error)
-
-import Language.Haskell.Liquid.GHC.API as Ghc hiding (Located)
-
-import Control.Monad.Except (MonadError, throwError)
-import Control.Monad.State
-import qualified Data.Maybe as Mb --(fromMaybe, isNothing)
-
-import qualified Text.PrettyPrint.HughesPJ as PJ
-import qualified Data.List as L
-import qualified Data.HashMap.Strict as M
-import Language.Fixpoint.Misc as Misc -- (singleton, sortNub)
-import qualified Language.Fixpoint.Types as F
-import Language.Haskell.Liquid.GHC.Misc
-import Language.Haskell.Liquid.Types.RefType
-import Language.Haskell.Liquid.Types.Types
-
--- import Language.Haskell.Liquid.Bare.Env
-
--- import Language.Haskell.Liquid.WiredIn (dcPrefix)
-
-
--- TODO: This is where unsorted stuff is for now. Find proper places for what follows.
-
-{-
--- WTF does this function do?
-makeSymbols :: (Id -> Bool) -> [Id] -> [F.Symbol] -> BareM [(F.Symbol, Var)]
-makeSymbols f vs xs
- = do svs <- M.toList <$> gets varEnv
- return $ L.nub ([ (x,v') | (x,v) <- svs, x `elem` xs, let (v',_,_) = joinVar vs (v,x,x)]
- ++ [ (F.symbol v, v) | v <- vs, f v, isDataConId v, hasBasicArgs $ varType v ])
- where
- -- arguments should be basic so that autogenerated singleton types are well formed
- hasBasicArgs (ForAllTy _ t) = hasBasicArgs t
- hasBasicArgs (FunTy _ tx t) = isBaseTy tx && hasBasicArgs t
- hasBasicArgs _ = True
-
--}
-
-freeSymbols :: (F.Reftable r, F.Reftable r1, F.Reftable r2, TyConable c, TyConable c1, TyConable c2)
- => [F.Symbol]
- -> [(a1, Located (RType c2 tv2 r2))]
- -> [(a, Located (RType c1 tv1 r1))]
- -> [(Located (RType c tv r))]
- -> [LocSymbol]
-freeSymbols xs' xts yts ivs = [ lx | lx <- Misc.sortNub $ zs ++ zs' ++ zs'' , not (M.member (val lx) knownM) ]
- where
- knownM = M.fromList [ (x, ()) | x <- xs' ]
- zs = concatMap freeSyms (snd <$> xts)
- zs' = concatMap freeSyms (snd <$> yts)
- zs'' = concatMap freeSyms ivs
-
-
-
-freeSyms :: (F.Reftable r, TyConable c) => Located (RType c tv r) -> [LocSymbol]
-freeSyms ty = [ F.atLoc ty x | x <- tySyms ]
- where
- tySyms = Misc.sortNub $ concat $ efoldReft (\_ _ -> True) False (\_ _ -> []) (\_ -> []) (const ()) f (const id) F.emptySEnv [] (val ty)
- f γ _ r xs = let F.Reft (v, _) = F.toReft r in
- [ x | x <- F.syms r, x /= v, not (x `F.memberSEnv` γ)] : xs
-
--------------------------------------------------------------------------------
--- Renaming Type Variables in Haskell Signatures ------------------------------
--------------------------------------------------------------------------------
-runMapTyVars :: Type -> SpecType -> (PJ.Doc -> PJ.Doc -> Error) -> Either Error MapTyVarST
-runMapTyVars τ t err = execStateT (mapTyVars τ t) (MTVST [] err)
-
-data MapTyVarST = MTVST
- { vmap :: [(Var, RTyVar)]
- , errmsg :: PJ.Doc -> PJ.Doc -> Error
- }
-
-mapTyVars :: Type -> SpecType -> StateT MapTyVarST (Either Error) ()
-mapTyVars t (RImpF _ _ t' _)
- = mapTyVars t t'
-mapTyVars (FunTy { ft_arg = τ, ft_res = τ'}) t
- | isClassPred τ
- = mapTyVars τ' t
-mapTyVars (FunTy { ft_arg = τ, ft_res = τ'}) (RFun _ t t' _)
- = mapTyVars τ t >> mapTyVars τ' t'
-mapTyVars τ (RAllT _ t _)
- = mapTyVars τ t
-mapTyVars (TyConApp _ τs) (RApp _ ts _ _)
- = zipWithM_ mapTyVars τs (matchKindArgs' τs ts)
-mapTyVars (TyVarTy α) (RVar a _)
- = do s <- get
- s' <- mapTyRVar α a s
- put s'
-mapTyVars τ (RAllP _ t)
- = mapTyVars τ t
-mapTyVars τ (RAllE _ _ t)
- = mapTyVars τ t
-mapTyVars τ (RRTy _ _ _ t)
- = mapTyVars τ t
-mapTyVars τ (REx _ _ t)
- = mapTyVars τ t
-mapTyVars _ (RExprArg _)
- = return ()
-mapTyVars (AppTy τ τ') (RAppTy t t' _)
- = do mapTyVars τ t
- mapTyVars τ' t'
-mapTyVars _ (RHole _)
- = return ()
-mapTyVars k _ | isKind k
- = return ()
-mapTyVars (ForAllTy _ τ) t
- = mapTyVars τ t
-mapTyVars hsT lqT
- = do err <- errmsg <$> get
- throwError (err (F.pprint hsT) (F.pprint lqT))
-
-isKind :: Kind -> Bool
-isKind = classifiesTypeWithValues -- TODO:GHC-863 isStarKind k -- typeKind k
-
-
-mapTyRVar :: MonadError Error m
- => Var -> RTyVar -> MapTyVarST -> m MapTyVarST
-mapTyRVar α a s@(MTVST αas err)
- = case lookup α αas of
- Just a' | a == a' -> return s
- | otherwise -> throwError (err (F.pprint a) (F.pprint a'))
- Nothing -> return $ MTVST ((α,a):αas) err
-
-matchKindArgs' :: [Type] -> [SpecType] -> [SpecType]
-matchKindArgs' ts1 ts2 = reverse $ go (reverse ts1) (reverse ts2)
- where
- go (_:ts1) (t2:ts2) = t2:go ts1 ts2
- go ts [] | all isKind ts
- = (ofType <$> ts) :: [SpecType]
- go _ ts = ts
-
-
-matchKindArgs :: [SpecType] -> [SpecType] -> [SpecType]
-matchKindArgs ts1 ts2 = reverse $ go (reverse ts1) (reverse ts2)
- where
- go (_:ts1) (t2:ts2) = t2:go ts1 ts2
- go ts [] = ts
- go _ ts = ts
-
-mkVarExpr :: Id -> F.Expr
-mkVarExpr v
- | isFunVar v = F.mkEApp (varFunSymbol v) []
- | otherwise = F.eVar v -- EVar (symbol v)
-
-varFunSymbol :: Id -> Located F.Symbol
-varFunSymbol = dummyLoc . F.symbol . idDataCon
-
-isFunVar :: Id -> Bool
-isFunVar v = isDataConId v && not (null αs) && Mb.isNothing tf
- where
- (αs, t) = splitForAllTys $ varType v
- tf = splitFunTy_maybe t
-
--- the Vars we lookup in GHC don't always have the same tyvars as the Vars
--- we're given, so return the original var when possible.
--- see tests/pos/ResolvePred.hs for an example
-joinVar :: [Var] -> (Var, s, t) -> (Var, s, t)
-joinVar vs (v,s,t) = case L.find ((== showPpr v) . showPpr) vs of
- Just v' -> (v',s,t)
- Nothing -> (v,s,t)
-
-simpleSymbolVar :: Var -> F.Symbol
-simpleSymbolVar = dropModuleNames . F.symbol . showPpr . getName
-
-hasBoolResult :: Type -> Bool
-hasBoolResult (ForAllTy _ t) = hasBoolResult t
-hasBoolResult (FunTy { ft_res = t} ) | eqType boolTy t = True
-hasBoolResult (FunTy { ft_res = t} ) = hasBoolResult t
-hasBoolResult _ = False
diff --git a/src/Language/Haskell/Liquid/Bare/Plugged.hs b/src/Language/Haskell/Liquid/Bare/Plugged.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Plugged.hs
+++ /dev/null
@@ -1,277 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-
-module Language.Haskell.Liquid.Bare.Plugged
- ( makePluggedSig
- , makePluggedDataCon
- ) where
-
-import Prelude hiding (error)
-import Data.Generics.Aliases (mkT)
-import Data.Generics.Schemes (everywhere)
-
-import Text.PrettyPrint.HughesPJ
-import qualified Control.Exception as Ex
-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
-import qualified Language.Fixpoint.Types as F
-import qualified Language.Fixpoint.Types.Visitor as F
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import Language.Haskell.Liquid.GHC.Types (StableName, mkStableName)
-import Language.Haskell.Liquid.Types.RefType ()
-import Language.Haskell.Liquid.Types
-import qualified Language.Haskell.Liquid.Misc as Misc
-import qualified Language.Haskell.Liquid.Bare.Types as Bare
-import qualified Language.Haskell.Liquid.Bare.Misc as Bare
-
----------------------------------------------------------------------------------------
--- [NOTE: Plug-Holes-TyVars] We have _two_ versions of `plugHoles:
--- * `HsTyVars` ensures that the returned signature uses the GHC type variables;
--- We need this as these tyvars can appear in the SOURCE (as type annotations, or
--- as the types of lambdas) and renaming them will cause problems;
--- * `LqTyVars` ensures that the returned signatuer uses the LIQUID type variables;
--- We need this e.g. for class specifications where we cannot change the tyvars
--- used inside method signatures as that messes up the type for the data-constructor
--- for the dictionary (as we need to use the same tyvars as are "bound" in the class
--- definition).
--- In short, use `HsTyVars` when we also have to analyze the binder's SOURCE; and
--- otherwise, use `LqTyVars`.
----------------------------------------------------------------------------------------
-
---------------------------------------------------------------------------------
--- | NOTE: Be *very* careful with the use functions from RType -> GHC.Type,
--- e.g. toType, in this module as they cannot handle LH type holes. Since
--- this module is responsible for plugging the holes we obviously cannot
--- assume, as in e.g. L.H.L.Constraint.* that they do not appear.
---------------------------------------------------------------------------------
-makePluggedSig :: ModName -> F.TCEmb Ghc.TyCon -> TyConMap -> S.HashSet StableName
- -> Bare.PlugTV Ghc.Var -> LocSpecType
- -> LocSpecType
-
-makePluggedSig name embs tyi exports kx t
- | Just x <- kxv = mkPlug x
- | otherwise = t
- where
- kxv = Bare.plugSrc kx
- mkPlug x = plugHoles kx embs tyi r τ t
- where
- τ = Ghc.expandTypeSynonyms (Ghc.varType x)
- r = maybeTrue x name exports
- -- x = case kx of { Bare.HsTV x -> x ; Bare.LqTV x -> x }
-
-
--- makePluggedDataCon = makePluggedDataCon_old
--- plugHoles = plugHoles_old
--- makePluggedDataCon = makePluggedDataCon_new
-
--- plugHoles _ = plugHoles_old
-
-plugHoles :: (Ghc.NamedThing a, PPrint a, Show a)
- => Bare.PlugTV a
- -> F.TCEmb Ghc.TyCon
- -> Bare.TyConMap
- -> (SpecType -> RReft -> RReft)
- -> Ghc.Type
- -> LocSpecType
- -> LocSpecType
-plugHoles (Bare.HsTV x) a b = plugHoles_old a b x
-plugHoles (Bare.LqTV x) a b = plugHoles_new a b x
-plugHoles _ _ _ = \_ _ t -> t
-
-
-makePluggedDataCon :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> Located DataConP -> Located DataConP
-makePluggedDataCon embs tyi ldcp
- | mismatchFlds = Ex.throw (err "fields")
- | mismatchTyVars = Ex.throw (err "type variables")
- | otherwise = F.atLoc ldcp $ F.notracepp "makePluggedDataCon" $ dcp
- { dcpFreeTyVars = dcVars
- , dcpTyArgs = reverse tArgs
- , dcpTyRes = tRes
- }
- where
- (tArgs, tRes) = plugMany embs tyi ldcp (das, dts, dt) (dcVars, dcArgs, dcpTyRes dcp)
- (das, _, dts, dt) = {- F.notracepp ("makePluggedDC: " ++ F.showpp dc) $ -} Ghc.dataConSig dc
- dcArgs = filter (not . isClassType . snd) $ reverse (dcpTyArgs dcp)
- dcVars = if isGADT
- then padGADVars $ L.nub (dcpFreeTyVars dcp ++ (concatMap (map ty_var_value . freeTyVars) (dcpTyRes dcp:(snd <$> dcArgs))))
- else dcpFreeTyVars dcp
- dc = dcpCon dcp
- dcp = val ldcp
-
- isGADT = Ghc.isGadtSyntaxTyCon $ Ghc.dataConTyCon dc
-
- -- hack to match LH and GHC GADT vars, since it is unclear how ghc generates free vars
- padGADVars vs = (RTV <$> take (length das - length vs) das) ++ vs
-
- mismatchFlds = length dts /= length dcArgs
- mismatchTyVars = length das /= length dcVars
- err things = ErrBadData (GM.fSrcSpan dcp) (pprint dc) ("GHC and Liquid specifications have different numbers of" <+> things) :: UserError
-
-
--- | @plugMany@ is used to "simultaneously" plug several different types,
--- e.g. as arise in the fields of a data constructor. To do so we create
--- a single "function type" that is then passed into @plugHoles@.
--- We also pass in the type parameters as dummy arguments, because, e.g.
--- we want @plugMany@ on the two types
---
--- forall a. a -> a -> Bool
--- forall b. _ -> _ -> _
---
--- to return something like
---
--- forall b. b -> b -> Bool
---
--- and not, forall b. a -> a -> Bool.
-
-plugMany :: F.TCEmb Ghc.TyCon -> Bare.TyConMap
- -> Located DataConP
- -> ([Ghc.Var], [Ghc.Type], Ghc.Type) -- ^ hs type
- -> ([RTyVar] , [(F.Symbol, SpecType)], SpecType) -- ^ lq type
- -> ([(F.Symbol, SpecType)], SpecType) -- ^ plugged lq type
-plugMany embs tyi ldcp (hsAs, hsArgs, hsRes) (lqAs, lqArgs, lqRes)
- = F.notracepp msg (drop nTyVars (zip xs ts), t)
- where
- (_,(xs,ts,_), t) = bkArrow (val pT)
- pT = plugHoles (Bare.LqTV dcName) embs tyi (const killHoles) hsT (F.atLoc ldcp lqT)
- hsT = foldr (Ghc.mkFunTy Ghc.VisArg) hsRes hsArgs'
- lqT = foldr (uncurry rFun) lqRes lqArgs'
- hsArgs' = [ Ghc.mkTyVarTy a | a <- hsAs] ++ hsArgs
- lqArgs' = [(F.dummySymbol, RVar a mempty) | a <- lqAs] ++ lqArgs
- nTyVars = length hsAs -- == length lqAs
- dcName = Ghc.dataConName . dcpCon . val $ ldcp
- msg = "plugMany: " ++ F.showpp (dcName, hsT, lqT)
-
-plugHoles_old, plugHoles_new
- :: (Ghc.NamedThing a, PPrint a, Show a)
- => F.TCEmb Ghc.TyCon
- -> Bare.TyConMap
- -> a
- -> (SpecType -> RReft -> RReft)
- -> Ghc.Type
- -> LocSpecType
- -> LocSpecType
-
--- NOTE: this use of toType is safe as rt' is derived from t.
-plugHoles_old tce tyi x f t0 zz@(Loc l l' st0)
- = Loc l l'
- . mkArrow (zip (updateRTVar <$> αs') rs) ps' [] []
- . makeCls cs'
- . goPlug tce tyi err f (subts su rt)
- . mapExprReft (\_ -> F.applyCoSub coSub)
- . subts su
- $ st
- where
- tyvsmap = case Bare.runMapTyVars (toType rt) st err of
- Left e -> Ex.throw e
- Right s -> Bare.vmap s
- su = [(y, rTyVar x) | (x, y) <- tyvsmap]
- su' = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)]
- coSub = M.fromList [(F.symbol y, F.FObj (F.symbol x)) | (y, x) <- su]
- ps' = fmap (subts su') <$> ps
- cs' = [(F.dummySymbol, RApp c ts [] mempty) | (c, ts) <- cs ]
- (αs', rs) = unzip αs
- (αs,_,cs,rt) = bkUnivClass (F.notracepp "hs-spec" $ ofType (Ghc.expandTypeSynonyms t0) :: SpecType)
- (_,ps,_ ,st) = bkUnivClass (F.notracepp "lq-spec" st0)
-
- makeCls cs t = foldr (uncurry rFun) t cs
- err hsT lqT = ErrMismatch (GM.fSrcSpan zz) (pprint x)
- (text "Plugged Init types old")
- (pprint $ Ghc.expandTypeSynonyms t0)
- (pprint $ toRSort st0)
- (Just (hsT, lqT))
- (Ghc.getSrcSpan x)
-
-
-plugHoles_new tce tyi x f t0 zz@(Loc l l' st0)
- = Loc l l'
- . mkArrow (zip (updateRTVar <$> as'') rs) ps [] []
- . makeCls cs'
- . goPlug tce tyi err f rt'
- $ st
- where
- rt' = tx rt
- as'' = subRTVar su <$> as'
- (as',rs) = unzip as
- cs' = [ (F.dummySymbol, ct) | (c, t) <- cs, let ct = tx (RApp c t [] mempty) ]
- tx = subts su
- su = case Bare.runMapTyVars (toType rt) st err of
- Left e -> Ex.throw e
- Right s -> [ (rTyVar x, y) | (x, y) <- Bare.vmap s]
- (as,_,cs,rt) = bkUnivClass (ofType (Ghc.expandTypeSynonyms t0) :: SpecType)
- (_,ps,_ ,st) = bkUnivClass st0
-
- makeCls cs t = foldr (uncurry rFun) t cs
- err hsT lqT = ErrMismatch (GM.fSrcSpan zz) (pprint x)
- (text "Plugged Init types new")
- (pprint $ Ghc.expandTypeSynonyms t0)
- (pprint $ toRSort st0)
- (Just (hsT, lqT))
- (Ghc.getSrcSpan x)
-
-subRTVar :: [(RTyVar, RTyVar)] -> SpecRTVar -> SpecRTVar
-subRTVar su a@(RTVar v i) = Mb.maybe a (`RTVar` i) (lookup v su)
-
-goPlug :: F.TCEmb Ghc.TyCon -> Bare.TyConMap -> (Doc -> Doc -> Error) -> (SpecType -> RReft -> RReft) -> SpecType -> SpecType
- -> SpecType
-goPlug tce tyi err f = go
- where
- go t (RHole r) = (addHoles t') { rt_reft = f t r }
- where
- t' = everywhere (mkT $ addRefs tce tyi) t
- addHoles = everywhere (mkT $ addHole)
- -- NOTE: make sure we only add holes to RVar and RApp (NOT RFun)
- addHole :: SpecType -> SpecType
- addHole t@(RVar v _) = RVar v (f t (uReft ("v", hole)))
- addHole t@(RApp c ts ps _) = RApp c ts ps (f t (uReft ("v", hole)))
- addHole t = t
-
- go (RVar _ _) v@(RVar _ _) = v
- go t' (RImpF x i o r) = RImpF x i (go t' o) r
- go (RFun _ i o _) (RFun x i' o' r) = RFun x (go i i') (go o o') r
- go (RAllT _ t _) (RAllT a t' r) = RAllT a (go t t') r
- go (RAllT a t r) t' = RAllT a (go t t') r
- go t (RAllP p t') = RAllP p (go t t')
- go t (RAllE b a t') = RAllE b a (go t t')
- go t (REx b x t') = REx b x (go t t')
- go t (RRTy e r o t') = RRTy e r o (go t t')
- go (RAppTy t1 t2 _) (RAppTy t1' t2' r) = RAppTy (go t1 t1') (go t2 t2') r
- -- zipWithDefM: if ts and ts' have different length then the liquid and haskell types are different.
- -- keep different types for now, as a pretty error message will be created at Bare.Check
- go (RApp _ ts _ _) (RApp c ts' p r)
- | length ts == length ts' = RApp c (Misc.zipWithDef go ts $ Bare.matchKindArgs ts ts') p r
- go hsT lqT = Ex.throw (err (F.pprint hsT) (F.pprint lqT))
-
- -- otherwise = Ex.throw err
- -- If we reach the default case, there's probably an error, but we defer
- -- throwing it as checkGhcSpec does a much better job of reporting the
- -- problem to the user.
- -- go st _ = st
-
-addRefs :: F.TCEmb Ghc.TyCon -> TyConMap -> SpecType -> SpecType
-addRefs tce tyi (RApp c ts _ r) = RApp c' ts ps r
- where
- RApp c' _ ps _ = addTyConInfo tce tyi (RApp c ts [] r)
-addRefs _ _ t = t
-
-maybeTrue :: Ghc.NamedThing a => a -> ModName -> S.HashSet StableName -> SpecType -> RReft -> RReft
-maybeTrue x target exports t r
- | not (isFunTy t) && (Ghc.isInternalName name || inTarget && notExported)
- = r
- | otherwise
- = killHoles r
- where
- inTarget = Ghc.moduleName (Ghc.nameModule name) == getModName target
- name = Ghc.getName x
- notExported = not (mkStableName (Ghc.getName x) `S.member` exports)
-
--- killHoles r@(U (Reft (v, rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) }
-
-killHoles :: RReft -> RReft
-killHoles ur = ur { ur_reft = tx $ ur_reft ur }
- where
- tx r = {- traceFix ("killholes: r = " ++ showFix r) $ -} F.mapPredReft dropHoles r
- dropHoles = F.pAnd . filter (not . isHole) . F.conjuncts
diff --git a/src/Language/Haskell/Liquid/Bare/Resolve.hs b/src/Language/Haskell/Liquid/Bare/Resolve.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Resolve.hs
+++ /dev/null
@@ -1,1067 +0,0 @@
--- | This module has the code that uses the GHC definitions to:
--- 1. MAKE a name-resolution environment,
--- 2. USE the environment to translate plain symbols into Var, TyCon, etc.
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE TupleSections #-}
-
-module Language.Haskell.Liquid.Bare.Resolve
- ( -- * Creating the Environment
- makeEnv
-
- -- * Resolving symbols
- , ResolveSym (..)
- , Qualify (..)
- , qualifyTop, qualifyTopDummy
-
- -- * Looking up names
- , maybeResolveSym
- , lookupGhcDataCon
- , lookupGhcDnTyCon
- , lookupGhcTyCon
- , lookupGhcVar
- , lookupGhcNamedVar
-
- -- * Checking if names exist
- , knownGhcVar
- , knownGhcTyCon
- , knownGhcDataCon
- , knownGhcType
-
- -- * Misc
- , srcVars
-
- -- * Conversions from Bare
- , ofBareTypeE
- , ofBareType
- , ofBPVar
-
- -- * Post-processing types
- , txRefSort
- , errResolve
-
- -- * Fixing local variables
- , resolveLocalBinds
- , partitionLocalBinds
- ) where
-
-import qualified Control.Exception as Ex
-import qualified Data.List as L
-import qualified Data.HashSet as S
-import qualified Data.Maybe as Mb
-import qualified Data.HashMap.Strict as M
-import qualified Data.Text as T
-import qualified Text.PrettyPrint.HughesPJ as PJ
-
-import qualified Language.Fixpoint.Utils.Files as F
-import qualified Language.Fixpoint.Types as F
-import qualified Language.Fixpoint.Types.Visitor as F
-import qualified Language.Fixpoint.Misc as Misc
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import qualified Language.Haskell.Liquid.Misc as Misc
-import qualified Language.Haskell.Liquid.Types.RefType as RT
-import qualified Language.Haskell.Liquid.Types.Errors as Errors
-import Language.Haskell.Liquid.Types.Types
-import Language.Haskell.Liquid.Measure (BareSpec)
-import Language.Haskell.Liquid.Types.Specs hiding (BareSpec)
-import Language.Haskell.Liquid.Types.Visitors
-import Language.Haskell.Liquid.Bare.Types
-import Language.Haskell.Liquid.Bare.Misc
-import Language.Haskell.Liquid.WiredIn
-
-myTracepp :: (F.PPrint a) => String -> a -> a
-myTracepp = F.notracepp
-
--------------------------------------------------------------------------------
--- | Creating an environment
--------------------------------------------------------------------------------
-makeEnv :: Config -> GhcSrc -> LogicMap -> [(ModName, BareSpec)] -> Env
-makeEnv cfg src lmap specs = RE
- { reLMap = lmap
- , reSyms = syms
- , _reSubst = makeVarSubst src
- , _reTyThings = makeTyThingMap src
- , reQualImps = _gsQualImps src
- , reAllImps = _gsAllImps src
- , reLocalVars = makeLocalVars src
- , reSrc = src
- , reGlobSyms = S.fromList globalSyms
- , reCfg = cfg
- }
- where
- globalSyms = concatMap getGlobalSyms specs
- syms = [ (F.symbol v, v) | v <- vars ]
- vars = srcVars src
-
-getGlobalSyms :: (ModName, BareSpec) -> [F.Symbol]
-getGlobalSyms (_, spec)
- = filter (not . GM.isQualifiedSym)
- $ (mbName <$> measures spec)
- ++ (mbName <$> cmeasures spec)
- ++ (mbName <$> imeasures spec)
- where
- mbName = F.val . msName
-
-makeLocalVars :: GhcSrc -> LocalVars
-makeLocalVars = localVarMap . localBinds . _giCbs
-
--- TODO: rewrite using CoreVisitor
-localBinds :: [Ghc.CoreBind] -> [Ghc.Var]
-localBinds = concatMap (bgo S.empty)
- where
- add x g = maybe g (`S.insert` g) (localKey x)
- adds b g = foldr add g (Ghc.bindersOf b)
- take x g = maybe [] (\k -> if S.member k g then [] else [x]) (localKey x)
- pgo g (x, e) = take x g ++ go (add x g) e
- bgo g (Ghc.NonRec x e) = pgo g (x, e)
- bgo g (Ghc.Rec xes) = concatMap (pgo g) xes
- go g (Ghc.App e a) = concatMap (go g) [e, a]
- go g (Ghc.Lam _ e) = go g e
- go g (Ghc.Let b e) = bgo g b ++ go (adds b g) e
- go g (Ghc.Tick _ e) = go g e
- go g (Ghc.Cast e _) = go g e
- go g (Ghc.Case e _ _ cs) = go g e ++ concatMap (go g . Misc.thd3) cs
- go _ (Ghc.Var _) = []
- go _ _ = []
-
-localVarMap :: [Ghc.Var] -> LocalVars
-localVarMap vs =
- Misc.group [ (x, (i, v)) | v <- vs
- , x <- Mb.maybeToList (localKey v)
- , let i = F.srcLine v
- ]
-
-localKey :: Ghc.Var -> Maybe F.Symbol
-localKey v
- | isLocal m = Just x
- | otherwise = Nothing
- where
- (m, x) = splitModuleNameExact . GM.dropModuleUnique . F.symbol $ v
-
-makeVarSubst :: GhcSrc -> F.Subst
-makeVarSubst src = F.mkSubst unqualSyms
- where
- unqualSyms = [ (x, mkVarExpr v)
- | (x, mxs) <- M.toList (makeSymMap src)
- , v <- Mb.maybeToList (okUnqualified me mxs)
- , not (isWiredInName x)
- ]
- me = F.symbol (_giTargetMod src)
-
--- | @okUnqualified mod mxs@ takes @mxs@ which is a list of modulenames-var
--- pairs all of which have the same unqualified symbol representation.
--- The function returns @Just v@ if
--- 1. that list is a singleton i.e. there is a UNIQUE unqualified version, OR
--- 2. there is a version whose module equals @me@.
-
-okUnqualified :: F.Symbol -> [(F.Symbol, a)] -> Maybe a
-okUnqualified _ [(_, x)] = Just x
-okUnqualified me mxs = go mxs
- where
- go [] = Nothing
- go ((m,x) : rest)
- | me == m = Just x
- | otherwise = go rest
-
-
-makeSymMap :: GhcSrc -> M.HashMap F.Symbol [(F.Symbol, Ghc.Var)]
-makeSymMap src = Misc.group [ (sym, (m, x))
- | x <- srcVars src
- , let (m, sym) = qualifiedSymbol x ]
-
-makeTyThingMap :: GhcSrc -> TyThingMap
-makeTyThingMap src =
- Misc.group [ (x, (m, t)) | t <- srcThings src
- , tSym <- Mb.maybeToList (tyThingSymbol t)
- , let (m, x) = qualifiedSymbol tSym
- , not (isLocal m)
- ]
-
-tyThingSymbol :: Ghc.TyThing -> Maybe F.Symbol
-tyThingSymbol (Ghc.AnId x) = Just (F.symbol x)
-tyThingSymbol (Ghc.ATyCon c) = Just (F.symbol c)
-tyThingSymbol (Ghc.AConLike d) = conLikeSymbol d
-tyThingSymbol _tt = Nothing -- panic Nothing ("TODO: tyThingSymbol" ++ showPpr tt)
-
-
-conLikeSymbol :: Ghc.ConLike -> Maybe F.Symbol
-conLikeSymbol (Ghc.RealDataCon d) = Just (F.symbol d)
-conLikeSymbol _z = Nothing -- panic Nothing ("TODO: conLikeSymbol -- " ++ showPpr z)
-
-
-
-
-isLocal :: F.Symbol -> Bool
-isLocal = isEmptySymbol
-
-qualifiedSymbol :: (F.Symbolic a) => a -> (F.Symbol, F.Symbol)
-qualifiedSymbol = splitModuleNameExact . F.symbol
-
-isEmptySymbol :: F.Symbol -> Bool
-isEmptySymbol x = F.lengthSym x == 0
-
-srcThings :: GhcSrc -> [Ghc.TyThing]
-srcThings src = myTracepp "SRCTHINGS"
- $ Misc.hashNubWith F.showpp (_gsTyThings src ++ mySrcThings src)
-
-mySrcThings :: GhcSrc -> [Ghc.TyThing]
-mySrcThings src = [ Ghc.AnId x | x <- vars ]
- ++ [ Ghc.ATyCon c | c <- tcs ]
- ++ [ aDataCon d | d <- dcs ]
- where
- vars = Misc.sortNub $ dataConVars dcs ++ srcVars src
- dcs = Misc.sortNub $ concatMap Ghc.tyConDataCons tcs
- tcs = Misc.sortNub $ srcTyCons src
- aDataCon = Ghc.AConLike . Ghc.RealDataCon
-
-srcTyCons :: GhcSrc -> [Ghc.TyCon]
-srcTyCons src = concat
- [ _gsTcs src
- , _gsFiTcs src
- , _gsPrimTcs src
- , srcVarTcs src
- ]
-
-srcVarTcs :: GhcSrc -> [Ghc.TyCon]
-srcVarTcs = varTyCons . srcVars
-
-varTyCons :: [Ghc.Var] -> [Ghc.TyCon]
-varTyCons = concatMap (typeTyCons . Ghc.dropForAlls . Ghc.varType)
-
-typeTyCons :: Ghc.Type -> [Ghc.TyCon]
-typeTyCons t = tops t ++ inners t
- where
- tops = Mb.maybeToList . Ghc.tyConAppTyCon_maybe
- inners = concatMap typeTyCons . snd . Ghc.splitAppTys
-
--- | We prioritize the @Ghc.Var@ in @srcVars@ because @_giDefVars@ and @gsTyThings@
--- have _different_ values for the same binder, with different types where the
--- type params are alpha-renamed. However, for absref, we need _the same_
--- type parameters as used by GHC as those are used inside the lambdas and
--- other bindings in the code. See also [NOTE: Plug-Holes-TyVars] and
--- tests-absref-pos-Papp00.hs
-
-srcVars :: GhcSrc -> [Ghc.Var]
-srcVars src = filter Ghc.isId . fmap Misc.thd3 . Misc.fstByRank $ concat
- [ key "SRC-VAR-DEF" 0 <$> _giDefVars src
- , key "SRC-VAR-DER" 1 <$> S.toList (_giDerVars src)
- , key "SRC-VAR-IMP" 2 <$> _giImpVars src
- , key "SRC-VAR-USE" 3 <$> _giUseVars src
- , key "SRC-VAR-THN" 4 <$> [ x | Ghc.AnId x <- _gsTyThings src ]
- ]
- where
- key :: String -> Int -> Ghc.Var -> (Int, F.Symbol, Ghc.Var)
- key _ i x = (i, F.symbol x, {- dump s -} x)
- _dump msg x = fst . myTracepp msg $ (x, RT.ofType (Ghc.expandTypeSynonyms (Ghc.varType x)) :: SpecType)
-
-dataConVars :: [Ghc.DataCon] -> [Ghc.Var]
-dataConVars dcs = concat
- [ Ghc.dataConWorkId <$> dcs
- , Ghc.dataConWrapId <$> dcs
- ]
-
--------------------------------------------------------------------------------
--- | Qualify various names
--------------------------------------------------------------------------------
-qualifyTop :: (Qualify a) => Env -> ModName -> F.SourcePos -> a -> a
-qualifyTop env name l = qualify env name l []
-
-qualifyTopDummy :: (Qualify a) => Env -> ModName -> a -> a
-qualifyTopDummy env name = qualifyTop env name dummySourcePos
-
-dummySourcePos :: F.SourcePos
-dummySourcePos = F.loc (F.dummyLoc ())
-
-class Qualify a where
- qualify :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a
-
-instance Qualify TyConMap where
- qualify env name l bs tyi = tyi
- { tcmTyRTy = tx <$> tcmTyRTy tyi
- , tcmFIRTy = tx <$> tcmFIRTy tyi
- }
- where
- tx :: (Qualify a) => a -> a
- tx = qualify env name l bs
-
-instance Qualify TyConP where
- qualify env name _ bs tcp = tcp { tcpSizeFun = qualify env name (tcpLoc tcp) bs <$> tcpSizeFun tcp }
-
-instance Qualify SizeFun where
- qualify env name _ bs (SymSizeFun lx) = SymSizeFun (qualify env name (F.loc lx) bs lx)
- qualify _ _ _ _ sf = sf
-
-instance Qualify F.Equation where
- qualify _env _name _l _bs x = x -- TODO-REBARE
--- REBARE: qualifyAxiomEq :: Bare.Env -> Var -> Subst -> AxiomEq -> AxiomEq
--- REBARE: qualifyAxiomEq v su eq = subst su eq { eqName = symbol v}
-
-instance Qualify F.Symbol where
- qualify env name l bs x = qualifySymbol env name l bs x
-
-qualifySymbol :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> F.Symbol -> F.Symbol
-qualifySymbol env name l bs x
- | isSpl = x
- | otherwise = case resolveLocSym env name "Symbol" (F.Loc l l x) of
- Left _ -> x
- Right v -> v
- where
- isSpl = isSplSymbol env bs x
-
-isSplSymbol :: Env -> [F.Symbol] -> F.Symbol -> Bool
-isSplSymbol env bs x
- = isWiredInName x
- || elem x bs
- || S.member x (reGlobSyms env)
-
-instance (Qualify a) => Qualify (Located a) where
- qualify env name l bs = fmap (qualify env name l bs)
-
-instance (Qualify a) => Qualify [a] where
- qualify env name l bs = fmap (qualify env name l bs)
-
-instance (Qualify a) => Qualify (Maybe a) where
- qualify env name l bs = fmap (qualify env name l bs)
-
-instance Qualify Body where
- qualify env name l bs (P p) = P (qualify env name l bs p)
- qualify env name l bs (E e) = E (qualify env name l bs e)
- qualify env name l bs (R x p) = R x (qualify env name l bs p)
-
-instance Qualify TyConInfo where
- qualify env name l bs tci = tci { sizeFunction = qualify env name l bs <$> sizeFunction tci }
-
-instance Qualify RTyCon where
- qualify env name l bs rtc = rtc { rtc_info = qualify env name l bs (rtc_info rtc) }
-
-instance Qualify (Measure SpecType Ghc.DataCon) where
- qualify env name _ bs m = m -- FIXME substEnv env name bs $
- { msName = qualify env name l bs lname
- , msEqns = qualify env name l bs <$> msEqns m
- }
- where
- l = F.loc lname
- lname = msName m
-
-
-instance Qualify (Def ty ctor) where
- qualify env name l bs d = d
- { body = qualify env name l (bs ++ bs') (body d) }
- where
- bs' = fst <$> binds d
-
-instance Qualify BareMeasure where
- qualify env name l bs m = m
- { msEqns = qualify env name l bs (msEqns m)
- }
-
-instance Qualify DataCtor where
- qualify env name l bs c = c
- { dcTheta = qualify env name l bs (dcTheta c)
- , dcFields = qualify env name l bs (dcFields c)
- , dcResult = qualify env name l bs (dcResult c)
- }
-
-instance Qualify DataDecl where
- qualify env name l bs d = d
- { tycDCons = qualify env name l bs (tycDCons d)
- , tycPropTy = qualify env name l bs (tycPropTy d)
- }
-
-instance Qualify ModSpecs where
- qualify env name l bs = Misc.hashMapMapWithKey (\_ -> qualify env name l bs)
-
-instance Qualify b => Qualify (a, b) where
- qualify env name l bs (x, y) = (x, qualify env name l bs y)
-
-instance Qualify BareSpec where
- qualify = qualifyBareSpec
-
-qualifyBareSpec :: Env -> ModName -> F.SourcePos -> [F.Symbol] -> BareSpec -> BareSpec
-qualifyBareSpec env name l bs sp = sp
- { measures = qualify env name l bs (measures sp)
- , asmSigs = qualify env name l bs (asmSigs sp)
- , sigs = qualify env name l bs (sigs sp)
- , localSigs = qualify env name l bs (localSigs sp)
- , reflSigs = qualify env name l bs (reflSigs sp)
- , dataDecls = qualify env name l bs (dataDecls sp)
- , newtyDecls = qualify env name l bs (newtyDecls sp)
- , ialiases = [ (f x, f y) | (x, y) <- ialiases sp ]
- }
- where f = qualify env name l bs
-
-instance Qualify F.Expr where
- qualify = substEnv
-
-instance Qualify RReft where
- qualify = substEnv
-
-instance Qualify F.Qualifier where
- qualify env name _ bs q = q { F.qBody = qualify env name (F.qPos q) bs' (F.qBody q) }
- where
- bs' = bs ++ (F.qpSym <$> F.qParams q)
-
-substEnv :: (F.Subable a) => Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a
-substEnv env name l bs = F.substa (qualifySymbol env name l bs)
-
-instance Qualify SpecType where
- qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5
-
-instance Qualify BareType where
- qualify x1 x2 x3 x4 x5 = emapReft (substFreeEnv x1 x2 x3) x4 x5
-
-substFreeEnv :: (F.Subable a) => Env -> ModName -> F.SourcePos -> [F.Symbol] -> a -> a
-substFreeEnv env name l bs = F.substf (F.EVar . qualifySymbol env name l bs)
-
--------------------------------------------------------------------------------
-lookupGhcNamedVar :: (Ghc.NamedThing a, F.Symbolic a) => Env -> ModName -> a -> Maybe Ghc.Var
--------------------------------------------------------------------------------
-lookupGhcNamedVar env name z = maybeResolveSym env name "Var" lx
- where
- lx = GM.namedLocSymbol z
-
-lookupGhcVar :: Env -> ModName -> String -> LocSymbol -> Ghc.Var
-lookupGhcVar env name kind lx =
- case resolveLocSym env name kind lx of
- Right v -> Mb.fromMaybe v (lookupLocalVar env lx [v])
- Left e -> Mb.fromMaybe (err e) (lookupLocalVar env lx [])
- where
- -- err e = Misc.errorP "error-lookupGhcVar" (F.showpp (e, F.loc lx, lx))
- err = Ex.throw
-
--- | @lookupLocalVar@ takes as input the list of "global" (top-level) vars
--- that also match the name @lx@; we then pick the "closest" definition.
--- See tests/names/LocalSpec.hs for a motivating example.
-
-lookupLocalVar :: Env -> LocSymbol -> [Ghc.Var] -> Maybe Ghc.Var
-lookupLocalVar env lx gvs = Misc.findNearest lxn kvs
- where
- _msg = "LOOKUP-LOCAL: " ++ F.showpp (F.val lx, lxn, kvs)
- kvs = gs ++ M.lookupDefault [] x (reLocalVars env)
- gs = [(F.srcLine v, v) | v <- gvs]
- lxn = F.srcLine lx
- (_, x) = unQualifySymbol (F.val lx)
-
-
-lookupGhcDataCon :: Env -> ModName -> String -> LocSymbol -> Ghc.DataCon
-lookupGhcDataCon = strictResolveSym
-
-lookupGhcTyCon :: Env -> ModName -> String -> LocSymbol -> Ghc.TyCon
-lookupGhcTyCon env name k lx = myTracepp ("LOOKUP-TYCON: " ++ F.showpp (val lx))
- $ strictResolveSym env name k lx
-
-lookupGhcDnTyCon :: Env -> ModName -> String -> DataName -> Maybe Ghc.TyCon
-lookupGhcDnTyCon env name msg = failMaybe env name . lookupGhcDnTyConE env name msg
-
-lookupGhcDnTyConE :: Env -> ModName -> String -> DataName -> Either UserError Ghc.TyCon
-lookupGhcDnTyConE env name msg (DnCon s)
- = lookupGhcDnCon env name msg s
-lookupGhcDnTyConE env name msg (DnName s)
- = case resolveLocSym env name msg s of
- Right r -> Right r
- Left e -> case lookupGhcDnCon env name msg s of
- Right r -> Right r
- Left _ -> Left e
-
-lookupGhcDnCon :: Env -> ModName -> String -> LocSymbol -> Either UserError Ghc.TyCon
-lookupGhcDnCon env name msg = fmap Ghc.dataConTyCon . resolveLocSym env name msg
-
--------------------------------------------------------------------------------
--- | Checking existence of names
--------------------------------------------------------------------------------
-knownGhcType :: Env -> ModName -> LocBareType -> Bool
-knownGhcType env name (F.Loc l _ t) =
- case ofBareTypeE env name l Nothing t of
- Left e -> myTracepp ("knownType: " ++ F.showpp (t, e)) $ False
- Right _ -> True
-
-
-
-_rTypeTyCons :: (Ord c) => RType c tv r -> [c]
-_rTypeTyCons = Misc.sortNub . foldRType f []
- where
- f acc t@(RApp {}) = rt_tycon t : acc
- f acc _ = acc
-
--- Aargh. Silly that each of these is the SAME code, only difference is the type.
-
-knownGhcVar :: Env -> ModName -> LocSymbol -> Bool
-knownGhcVar env name lx = Mb.isJust v
- where
- v :: Maybe Ghc.Var -- This annotation is crucial
- v = myTracepp ("knownGhcVar " ++ F.showpp lx)
- $ maybeResolveSym env name "known-var" lx
-
-knownGhcTyCon :: Env -> ModName -> LocSymbol -> Bool
-knownGhcTyCon env name lx = myTracepp msg $ Mb.isJust v
- where
- msg = ("knownGhcTyCon: " ++ F.showpp lx)
- v :: Maybe Ghc.TyCon -- This annotation is crucial
- v = maybeResolveSym env name "known-tycon" lx
-
-knownGhcDataCon :: Env -> ModName -> LocSymbol -> Bool
-knownGhcDataCon env name lx = Mb.isJust v
- where
- v :: Maybe Ghc.DataCon -- This annotation is crucial
- v = myTracepp ("knownGhcDataCon" ++ F.showpp lx)
- $ maybeResolveSym env name "known-datacon" lx
-
--------------------------------------------------------------------------------
--- | Using the environment
--------------------------------------------------------------------------------
-class ResolveSym a where
- resolveLocSym :: Env -> ModName -> String -> LocSymbol -> Either UserError a
-
-instance ResolveSym Ghc.Var where
- resolveLocSym = resolveWith "variable" $ \case
- Ghc.AnId x -> Just x
- _ -> Nothing
-
-instance ResolveSym Ghc.TyCon where
- resolveLocSym = resolveWith "type constructor" $ \case
- Ghc.ATyCon x -> Just x
- _ -> Nothing
-
-instance ResolveSym Ghc.DataCon where
- resolveLocSym = resolveWith "data constructor" $ \case
- Ghc.AConLike (Ghc.RealDataCon x) -> Just x
- _ -> Nothing
-
-
-{- Note [ResolveSym for Symbol]
-
-In case we need to resolve (aka qualify) a 'Symbol', we need to do some extra work. Generally speaking,
-all these 'ResolveSym' instances perform a lookup into a 'Map' keyed by the 'Symbol' in
-order to find a 'TyThing'. More specifically such map is known as the 'TyThingMap':
-
-type TyThingMap = M.HashMap F.Symbol [(F.Symbol, Ghc.TyThing)]
-
-This means, in practice, that we might have more than one result indexed by a given 'Symbol', and we need
-to make a choice. The function 'rankedThings' does this. By default, we try to extract only /identifiers/
-(i.e. a GHC's 'Id') out of an input 'TyThing', but in the case of test \"T1688\", something different happened.
-By tracing calls to 'rankedThings' (called by 'resolveLocSym') there were cases where we had something like
-this as our input TyThingMap:
-
-[
- 1 : T1688Lib : Data constructor T1688Lib.Lambda,
- 1 : T1688Lib : Identifier T1688Lib.Lambda
-]
-
-Here name resolution worked because 'resolveLocSym' used the 'ResolveSym' instance defined for 'GHC.Var' that
-looks only for 'Id's (contained inside 'Identifier's, and we had one). In some other cases, though,
-'resolveLocSym' got called with only this:
-
-[1 : T1688Lib : Data constructor T1688Lib.Lambda]
-
-This would /not/ yield a match, despite the fact a \"Data constructor\" in principle /does/ contain an 'Id'
-(it can be extracted out of a 'RealDataCon' by calling 'dataConWorkId'). In the case of test T1688, such
-failed lookup caused the 'Symbol' to /not/ qualify, which in turn caused the symbols inside the type synonym:
-
-ProofOf( Step (App (Lambda x e) v) e)
-
-To not qualify. Finally, by the time 'expand' was called, the 'ProofOf' type alias would be replaced with
-the correct refinement, but the unqualified 'Symbol's would now cause a test failure when refining the client
-module.
-
-It's not clear to me (Alfredo) why 'resolveLocSym' is called multiple times within the same module with
-different inputs, but it definitely makes sense to allow for the special case here, at least for 'Symbol's.
-
-Probably finding the /root cause/ would entail partially rewriting the name resoultion engine.
-
--}
-
-
-instance ResolveSym F.Symbol where
- resolveLocSym env name _ lx =
- -- If we can't resolve the input 'Symbol' from an 'Id', try again
- -- by grabbing the 'Id' of an 'AConLike', if any.
- -- See Note [ResolveSym for Symbol].
- let resolved = resolveLocSym env name "Var" lx
- <> resolveWith "variable" lookupVarInsideRealDataCon env name "Var" lx
- in case resolved of
- Left _ -> Right (val lx)
- Right (v :: Ghc.Var) -> Right (F.symbol v)
- where
- lookupVarInsideRealDataCon :: Ghc.TyThing -> Maybe Ghc.Var
- lookupVarInsideRealDataCon = \case
- Ghc.AConLike (Ghc.RealDataCon x) -> Just (Ghc.dataConWorkId x)
- _ -> Nothing
-
-
-
-resolveWith :: (PPrint a) => PJ.Doc -> (Ghc.TyThing -> Maybe a) -> Env -> ModName -> String -> LocSymbol
- -> Either UserError a
-resolveWith kind f env name str lx =
- -- case Mb.mapMaybe f things of
- case rankedThings f things of
- [] -> Left (errResolve kind str lx)
- [x] -> Right x
- xs -> Left $ ErrDupNames sp (pprint (F.val lx)) (pprint <$> xs)
- where
- -- oThings = Mb.mapMaybe (\(x, y) -> (x,) <$> f y) things
- _xSym = (F.val lx)
- sp = GM.fSrcSpanSrcSpan (F.srcSpan lx)
- things = myTracepp msg $ lookupTyThing env name lx
- msg = "resolveWith: " ++ str ++ " " ++ F.showpp (val lx)
-
-
-rankedThings :: (Misc.EqHash k) => (a -> Maybe b) -> [(k, a)] -> [b]
-rankedThings f ias = case Misc.sortOn fst (Misc.groupList ibs) of
- (_,ts):_ -> ts
- [] -> []
- where
- ibs = Mb.mapMaybe (\(k, x) -> (k,) <$> f x) ias
-
--------------------------------------------------------------------------------
--- | @lookupTyThing@ is the central place where we lookup the @Env@ to find
--- any @Ghc.TyThing@ that match that name. The code is a bit hairy as we
--- have various heuristics to approximiate how GHC resolves names. e.g.
--- see tests-names-pos-*.hs, esp. vector04.hs where we need the name `Vector`
--- to resolve to `Data.Vector.Vector` and not `Data.Vector.Generic.Base.Vector`...
--------------------------------------------------------------------------------
-lookupTyThing :: Env -> ModName -> LocSymbol -> [((Int, F.Symbol), Ghc.TyThing)]
--------------------------------------------------------------------------------
-lookupTyThing env name lsym = [ (k, t) | (k, ts) <- ordMatches, t <- ts]
-
- where
- ordMatches = Misc.sortOn fst (Misc.groupList matches)
- matches = myTracepp ("matches-" ++ msg)
- [ ((k, m), t) | (m, t) <- lookupThings env x
- , k <- myTracepp msg $ mm nameSym m mods ]
- msg = "lookupTyThing: " ++ F.showpp (lsym, x, mods)
- (x, mods) = symbolModules env (F.val lsym)
- nameSym = F.symbol name
- allowExt = allowExtResolution env lsym
- mm name m mods = myTracepp ("matchMod: " ++ F.showpp (lsym, name, m, mods, allowExt)) $
- matchMod env name m allowExt mods
-
--- | [NOTE:External-Resolution] @allowExtResolution@ determines whether a @LocSymbol@
--- can be resolved by a @TyThing@ that is _outside_ the module corresponding to @LocSymbol@.
--- We need to allow this, e.g. to resolve names like @Data.Set.Set@ with @Data.Set.Internal.Set@,
--- but should do so ONLY when the LocSymbol comes from a "hand-written" .spec file or
--- something from the LH prelude. Other names, e.g. from "machine-generated" .bspec files
--- should already be FULLY-qualified to to their actual definition (e.g. Data.Set.Internal.Set)
--- and so we should DISALLOW external-resolution in such cases.
-
-allowExtResolution :: Env -> LocSymbol -> Bool
-allowExtResolution env lx = case fileMb of
- Nothing -> True
- Just f -> myTracepp ("allowExt: " ++ show (f, tgtFile))
- $ f == tgtFile || Misc.isIncludeFile incDir f || F.isExtFile F.Spec f
- where
- tgtFile = _giTarget (reSrc env)
- incDir = _giIncDir (reSrc env)
- fileMb = Errors.srcSpanFileMb (GM.fSrcSpan lx)
-
-lookupThings :: Env -> F.Symbol -> [(F.Symbol, Ghc.TyThing)]
-lookupThings env x = myTracepp ("lookupThings: " ++ F.showpp x)
- $ Misc.fromFirstMaybes [] (get <$> [x, GM.stripParensSym x])
- where
- get z = M.lookup z (_reTyThings env)
-
-matchMod :: Env -> F.Symbol -> F.Symbol -> Bool -> Maybe [F.Symbol] -> [Int]
-matchMod env tgtName defName allowExt = go
- where
- go Nothing -- Score UNQUALIFIED names
- | defName == tgtName = [0] -- prioritize names defined in *this* module
- | otherwise = [matchImp env defName 1] -- prioritize directly imported modules over
- -- names coming from elsewhere, with a
-
- go (Just ms) -- Score QUALIFIED names
- | isEmptySymbol defName
- && ms == [tgtName] = [0] -- local variable, see tests-names-pos-local00.hs
- | ms == [defName] = [1]
- | allowExt && isExt = [matchImp env defName 2] -- to allow matching re-exported names e.g. Data.Set.union for Data.Set.Internal.union
- | otherwise = []
- where
- isExt = any (`isParentModuleOf` defName) ms
-
--- | Returns 'True' if the 'Symbol' given as a first argument represents a parent module for the second.
---
--- >>> L.symbolic "Data.Text" `isParentModuleOf` L.symbolic "Data.Text.Internal"
--- True
---
--- Invariants:
---
--- * The empty 'Symbol' is always considered the module prefix of the second,
--- in compliance with 'isPrefixOfSym' (AND: why?)
--- * If the parent \"hierarchy\" is smaller than the children's one, this is clearly not a parent module.
-isParentModuleOf :: F.Symbol -> F.Symbol -> Bool
-isParentModuleOf parentModule childModule
- | isEmptySymbol parentModule = True
- | otherwise =
- length parentHierarchy <= length childHierarchy && all (uncurry (==)) (zip parentHierarchy childHierarchy)
- where
- parentHierarchy :: [T.Text]
- parentHierarchy = T.splitOn "." . F.symbolText $ parentModule
-
- childHierarchy :: [T.Text]
- childHierarchy = T.splitOn "." . F.symbolText $ childModule
-
-
-symbolModules :: Env -> F.Symbol -> (F.Symbol, Maybe [F.Symbol])
-symbolModules env s = (x, glerb <$> modMb)
- where
- (modMb, x) = unQualifySymbol s
- glerb m = M.lookupDefault [m] m qImps
- qImps = qiNames (reQualImps env)
-
--- | @matchImp@ lets us prioritize @TyThing@ defined in directly imported modules over
--- those defined elsewhere. Specifically, in decreasing order of priority we have
--- TyThings that we:
--- * DIRECTLY imported WITHOUT qualification
--- * TRANSITIVELY imported (e.g. were re-exported by SOME imported module)
--- * QUALIFIED imported (so qualify the symbol to get this result!)
-
-matchImp :: Env -> F.Symbol -> Int -> Int
-matchImp env defName i
- | isUnqualImport = i
- | isQualImport = i + 2
- | otherwise = i + 1
- where
- isUnqualImport = S.member defName (reAllImps env) && not isQualImport
- isQualImport = S.member defName (qiModules (reQualImps env))
-
-
--- | `unQualifySymbol name sym` splits `sym` into a pair `(mod, rest)` where
--- `mod` is the name of the module, derived from `sym` if qualified.
-unQualifySymbol :: F.Symbol -> (Maybe F.Symbol, F.Symbol)
-unQualifySymbol sym
- | GM.isQualifiedSym sym = Misc.mapFst Just (splitModuleNameExact sym)
- | otherwise = (Nothing, sym)
-
-splitModuleNameExact :: F.Symbol -> (F.Symbol, F.Symbol)
-splitModuleNameExact x' = myTracepp ("splitModuleNameExact for " ++ F.showpp x)
- (GM.takeModuleNames x, GM.dropModuleNames x)
- where
- x = GM.stripParensSym x'
-
-errResolve :: PJ.Doc -> String -> LocSymbol -> UserError
-errResolve k msg lx = ErrResolve (GM.fSrcSpan lx) k (F.pprint (F.val lx)) (PJ.text msg)
-
--- symbolicString :: F.Symbolic a => a -> String
--- symbolicString = F.symbolString . F.symbol
-
--- | @strictResolve@ wraps the plain @resolve@ to throw an error
--- if the name being searched for is unknown.
-strictResolveSym :: (ResolveSym a) => Env -> ModName -> String -> LocSymbol -> a
-strictResolveSym env name kind x = case resolveLocSym env name kind x of
- Left err -> Misc.errorP "error-strictResolveSym" (F.showpp err) -- uError err
- Right val -> val
-
--- | @maybeResolve@ wraps the plain @resolve@ to return @Nothing@
--- if the name being searched for is unknown.
-maybeResolveSym :: (ResolveSym a) => Env -> ModName -> String -> LocSymbol -> Maybe a
-maybeResolveSym env name kind x = case resolveLocSym env name kind x of
- Left _ -> Nothing
- Right val -> Just val
-
--------------------------------------------------------------------------------
--- | @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)
- where
- fail = Ex.throw
- -- fail = Misc.errorP "error-ofBareType" . F.showpp
-
-ofBareTypeE :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> Either UserError SpecType
-ofBareTypeE env name l ps t = ofBRType env name (resolveReft env name l ps t) l t
-
-resolveReft :: Env -> ModName -> F.SourcePos -> Maybe [PVar BSort] -> BareType -> [F.Symbol] -> RReft -> RReft
-resolveReft env name l ps t bs
- = qualify env name l bs
- . txParam l RT.subvUReft (RT.uPVar <$> πs) t
- . fixReftTyVars t -- same as fixCoercions
- where
- πs = Mb.fromMaybe tπs ps
- tπs = ty_preds (toRTypeRep t)
-
-fixReftTyVars :: BareType -> RReft -> RReft
-fixReftTyVars bt = coSubRReft coSub
- where
- coSub = M.fromList [ (F.symbol a, F.FObj (specTvSymbol a)) | a <- tvs ]
- tvs = RT.allTyVars bt
- specTvSymbol = F.symbol . RT.bareRTyVar
-
-coSubRReft :: F.CoSub -> RReft -> RReft
-coSubRReft su r = r { ur_reft = coSubReft su (ur_reft r) }
-
-coSubReft :: F.CoSub -> F.Reft -> F.Reft
-coSubReft su (F.Reft (x, e)) = F.Reft (x, F.applyCoSub su e)
-
-
-ofBSort :: Env -> ModName -> F.SourcePos -> BSort -> RSort
-ofBSort env name l t = either (Misc.errorP "error-ofBSort" . F.showpp) id (ofBSortE env name l t)
-
-ofBSortE :: Env -> ModName -> F.SourcePos -> BSort -> Either UserError RSort
-ofBSortE env name l t = ofBRType env name (const id) l t
-
-ofBPVar :: Env -> ModName -> F.SourcePos -> BPVar -> RPVar
-ofBPVar env name l = fmap (ofBSort env name l)
-
---------------------------------------------------------------------------------
-txParam :: F.SourcePos -> ((UsedPVar -> UsedPVar) -> t) -> [UsedPVar] -> RType c tv r -> t
-txParam l f πs t = f (txPvar l (predMap πs t))
-
-txPvar :: F.SourcePos -> M.HashMap F.Symbol UsedPVar -> UsedPVar -> UsedPVar
-txPvar l m π = π { pargs = args' }
- where
- args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π)
- | otherwise = pargs π'
- π' = Mb.fromMaybe err $ M.lookup (pname π) m
- err = uError $ ErrUnbPred sp (pprint π)
- sp = GM.sourcePosSrcSpan l
-
-predMap :: [UsedPVar] -> RType c tv r -> M.HashMap F.Symbol UsedPVar
-predMap πs t = M.fromList [(pname π, π) | π <- πs ++ rtypePredBinds t]
-
-rtypePredBinds :: RType c tv r -> [UsedPVar]
-rtypePredBinds = map RT.uPVar . ty_preds . toRTypeRep
-
-
-
---------------------------------------------------------------------------------
-type Expandable r = ( PPrint r
- , F.Reftable r
- , SubsTy RTyVar (RType RTyCon RTyVar ()) r
- , F.Reftable (RTProp RTyCon RTyVar r))
-
-ofBRType :: (Expandable r) => Env -> ModName -> ([F.Symbol] -> r -> r) -> F.SourcePos -> BRType r
- -> Either UserError (RRType r)
-ofBRType env name f l t = go [] t
- where
- goReft bs r = return (f bs r)
- goRImpF bs x t1 t2 r = RImpF x <$> (rebind x <$> go bs t1) <*> go (x:bs) t2 <*> goReft bs r
- goRFun bs x t1 t2 r = RFun x <$> (rebind x <$> go bs t1) <*> go (x:bs) t2 <*> goReft bs r
- rebind x t = F.subst1 t (x, F.EVar $ rTypeValueVar t)
- go bs (RAppTy t1 t2 r) = RAppTy <$> go bs t1 <*> go bs t2 <*> goReft bs r
- go bs (RApp tc ts rs r) = goRApp bs tc ts rs r
- go bs (RImpF x t1 t2 r) = goRImpF bs x t1 t2 r
- go bs (RFun x t1 t2 r) = goRFun bs x t1 t2 r
- go bs (RVar a r) = RVar (RT.bareRTyVar a) <$> goReft bs r
- go bs (RAllT a t r) = RAllT a' <$> go bs t <*> goReft bs r
- where a' = dropTyVarInfo (mapTyVarValue RT.bareRTyVar a)
- go bs (RAllP a t) = RAllP a' <$> go bs t
- where a' = ofBPVar env name l a
- go bs (RAllE x t1 t2) = RAllE x <$> go bs t1 <*> go bs t2
- go bs (REx x t1 t2) = REx x <$> go bs t1 <*> go (x:bs) t2
- go bs (RRTy xts r o t) = RRTy <$> xts' <*> (goReft bs r) <*> (pure o) <*> go bs t
- where xts' = mapM (Misc.mapSndM (go bs)) xts
- go bs (RHole r) = RHole <$> goReft bs r
- go bs (RExprArg le) = return $ RExprArg (qualify env name l bs le)
- goRef bs (RProp ss (RHole r)) = rPropP <$> (mapM goSyms ss) <*> goReft bs r
- goRef bs (RProp ss t) = RProp <$> (mapM goSyms ss) <*> go bs t
- goSyms (x, t) = (x,) <$> ofBSortE env name l t
- goRApp bs tc ts rs r = bareTCApp <$> goReft bs r <*> lc' <*> mapM (goRef bs) rs <*> mapM (go bs) ts
- where
- lc' = F.atLoc lc <$> matchTyCon env name lc (length ts)
- lc = btc_tc tc
- -- goRApp _ _ _ _ = impossible Nothing "goRApp failed through to final case"
-
-{-
- -- TODO-REBARE: goRImpF bounds _ (RApp c ps' _ _) t _
- -- TODO-REBARE: | Just bnd <- M.lookup (btc_tc c) bounds
- -- TODO-REBARE: = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'
- -- TODO-REBARE: ts <- mapM go ts'
- -- TODO-REBARE: makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t
- -- TODO-REBARE: goRFun bounds _ (RApp c ps' _ _) t _
- -- TODO-REBARE: | Just bnd <- M.lookup (btc_tc c) bounds
- -- TODO-REBARE: = do let (ts', ps) = splitAt (length $ tyvars bnd) ps'
- -- TODO-REBARE: ts <- mapM go ts'
- -- TODO-REBARE: makeBound bnd ts [x | RVar (BTV x) _ <- ps] <$> go t
-
- -- TODO-REBARE: ofBareRApp env name t@(F.Loc _ _ !(RApp tc ts _ r))
- -- TODO-REBARE: | Loc l _ c <- btc_tc tc
- -- TODO-REBARE: , Just rta <- M.lookup c aliases
- -- TODO-REBARE: = appRTAlias l rta ts =<< resolveReft r
-
--}
-
-matchTyCon :: Env -> ModName -> LocSymbol -> Int -> Either UserError Ghc.TyCon
-matchTyCon env name lc@(Loc _ _ c) arity
- | isList c && arity == 1 = Right Ghc.listTyCon
- | isTuple c = Right tuplTc
- | otherwise = resolveLocSym env name msg lc
- where
- msg = "matchTyCon: " ++ F.showpp c
- tuplTc = Ghc.tupleTyCon Ghc.Boxed arity
-
-
-bareTCApp :: (Expandable r)
- => r
- -> Located Ghc.TyCon
- -> [RTProp RTyCon RTyVar r]
- -> [RType RTyCon RTyVar r]
- -> (RType RTyCon RTyVar r)
-bareTCApp r (Loc l _ c) rs ts | Just rhs <- Ghc.synTyConRhs_maybe c
- = if (GM.kindTCArity c < length ts)
- then Ex.throw err -- error (F.showpp err)
- else tyApp (RT.subsTyVars_meet su $ RT.ofType rhs) (drop nts ts) rs r
- where
- tvs = [ v | (v, b) <- zip (GM.tyConTyVarsDef c) (Ghc.tyConBinders c), GM.isAnonBinder b]
- su = zipWith (\a t -> (RT.rTyVar a, toRSort t, t)) tvs ts
- nts = length tvs
-
- err :: UserError
- err = ErrAliasApp (GM.sourcePosSrcSpan l) (pprint c) (Ghc.getSrcSpan c)
- (PJ.hcat [ PJ.text "Expects"
- , pprint (GM.realTcArity c)
- , PJ.text "arguments, but is given"
- , pprint (length ts) ] )
--- TODO expandTypeSynonyms here to
-bareTCApp r (Loc _ _ c) rs ts | Ghc.isFamilyTyCon c && isTrivial t
- = expandRTypeSynonyms (t `RT.strengthen` r)
- where t = RT.rApp c ts rs mempty
-
-bareTCApp r (Loc _ _ c) rs ts
- = RT.rApp c ts rs r
-
-
-tyApp :: F.Reftable r => RType c tv r -> [RType c tv r] -> [RTProp c tv r] -> r
- -> RType c tv r
-tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `F.meet` r')
-tyApp t [] [] r = t `RT.strengthen` r
-tyApp _ _ _ _ = panic Nothing $ "Bare.Type.tyApp on invalid inputs"
-
-expandRTypeSynonyms :: (Expandable r) => RRType r -> RRType r
-expandRTypeSynonyms = RT.ofType . Ghc.expandTypeSynonyms . RT.toType
-
-{-
-expandRTypeSynonyms :: (Expandable r) => RRType r -> RRType r
-expandRTypeSynonyms t
- | rTypeHasHole t = t
- | otherwise = expandRTypeSynonyms' t
-
-rTypeHasHole :: RType c tv r -> Bool
-rTypeHasHole = foldRType f False
- where
- f _ (RHole _) = True
- f b _ = b
--}
-
-------------------------------------------------------------------------------------------
--- | Is this the SAME as addTyConInfo? No. `txRefSort`
--- (1) adds the _real_ sorts to RProp,
--- (2) gathers _extra_ RProp at turns them into refinements,
--- e.g. tests/pos/multi-pred-app-00.hs
-------------------------------------------------------------------------------------------
-
-txRefSort :: TyConMap -> F.TCEmb Ghc.TyCon -> LocSpecType -> LocSpecType
-txRefSort tyi tce t = F.atLoc t $ mapBot (addSymSort (GM.fSrcSpan t) tce tyi) (val t)
-
-addSymSort :: Ghc.SrcSpan -> F.TCEmb Ghc.TyCon -> TyConMap -> SpecType -> SpecType
-addSymSort sp tce tyi (RApp rc@(RTyCon {}) ts rs r)
- = RApp rc ts (zipWith3 (addSymSortRef sp rc) pvs rargs [1..]) r'
- where
- (_, pvs) = RT.appRTyCon tce tyi rc ts
- -- pvs = rTyConPVs rc'
- (rargs, rrest) = splitAt (length pvs) rs
- r' = L.foldl' go r rrest
- go r (RProp _ (RHole r')) = r' `F.meet` r
- go r (RProp _ t' ) = let r' = Mb.fromMaybe mempty (stripRTypeBase t') in r `F.meet` r'
-
-addSymSort _ _ _ t
- = t
-
-addSymSortRef :: (PPrint s) => Ghc.SrcSpan -> s -> RPVar -> SpecProp -> Int -> SpecProp
-addSymSortRef sp rc p r i
- | isPropPV p
- = addSymSortRef' sp rc i p r
- | otherwise
- = panic Nothing "addSymSortRef: malformed ref application"
-
-addSymSortRef' :: (PPrint s) => Ghc.SrcSpan -> s -> Int -> RPVar -> SpecProp -> SpecProp
-addSymSortRef' _ _ _ p (RProp s (RVar v r)) | isDummy v
- = RProp xs t
- where
- t = ofRSort (pvType p) `RT.strengthen` r
- xs = spliceArgs "addSymSortRef 1" s p
-
-addSymSortRef' sp rc i p (RProp _ (RHole r@(MkUReft _ (Pr [up]))))
- | length xs == length ts
- = RProp xts (RHole r)
- | otherwise
- = -- Misc.errorP "ZONK" $ F.showpp (rc, pname up, i, length xs, length ts)
- uError $ ErrPartPred sp (pprint rc) (pprint $ pname up) i (length xs) (length ts)
- where
- xts = Misc.safeZipWithError "addSymSortRef'" xs ts
- xs = Misc.snd3 <$> pargs up
- ts = Misc.fst3 <$> pargs p
-
-addSymSortRef' _ _ _ _ (RProp s (RHole r))
- = RProp s (RHole r)
-
-addSymSortRef' _ _ _ p (RProp s t)
- = RProp xs t
- where
- xs = spliceArgs "addSymSortRef 2" s p
-
-spliceArgs :: String -> [(F.Symbol, b)] -> PVar t -> [(F.Symbol, t)]
-spliceArgs msg s p = go (fst <$> s) (pargs p)
- where
- go [] [] = []
- go [] ((s,x,_):as) = (x, s):go [] as
- go (x:xs) ((s,_,_):as) = (x,s):go xs as
- go xs [] = panic Nothing $ "spliceArgs: " ++ msg ++ "on XS=" ++ show xs
-
----------------------------------------------------------------------------------
--- RJ: formerly, `replaceLocalBinds` AFAICT
--- | @resolveLocalBinds@ resolves that the "free" variables that appear in the
--- type-sigs for non-toplevel binders (that correspond to other locally bound)
--- source variables that are visible at that at non-top-level scope.
--- e.g. tests-names-pos-local02.hs
----------------------------------------------------------------------------------
-resolveLocalBinds :: Env -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]
- -> [(Ghc.Var, LocBareType, Maybe [Located F.Expr])]
----------------------------------------------------------------------------------
-resolveLocalBinds env xtes = [ (x,t,es) | (x, (t, es)) <- topTs ++ replace locTs ]
- where
- (locTs, topTs) = partitionLocalBinds [ (x, (t, es)) | (x, t, es) <- xtes]
- replace = M.toList . replaceSigs . M.fromList
- replaceSigs sigm = coreVisitor replaceVisitor M.empty sigm cbs
- cbs = _giCbs (reSrc env)
-
-replaceVisitor :: CoreVisitor SymMap SigMap
-replaceVisitor = CoreVisitor
- { envF = addBind
- , bindF = updSigMap
- , exprF = \_ m _ -> m
- }
-
-addBind :: SymMap -> Ghc.Var -> SymMap
-addBind env v = case localKey v of
- Just vx -> M.insert vx (F.symbol v) env
- Nothing -> env
-
-updSigMap :: SymMap -> SigMap -> Ghc.Var -> SigMap
-updSigMap env m v = case M.lookup v m of
- Nothing -> m
- Just tes -> M.insert v (myTracepp ("UPD-LOCAL-SIG " ++ GM.showPpr v) $ renameLocalSig env tes) m
-
-renameLocalSig :: SymMap -> (LocBareType, Maybe [Located F.Expr])
- -> (LocBareType, Maybe [Located F.Expr])
-renameLocalSig env (t, es) = (F.substf tSub t, F.substf esSub es)
- where
- tSub = F.EVar . qualifySymMap env
- esSub = tSub `F.substfExcept` xs
- xs = ty_binds (toRTypeRep (F.val t))
-
-qualifySymMap :: SymMap -> F.Symbol -> F.Symbol
-qualifySymMap env x = M.lookupDefault x x env
-
-type SigMap = M.HashMap Ghc.Var (LocBareType, Maybe [Located F.Expr])
-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)
diff --git a/src/Language/Haskell/Liquid/Bare/ToBare.hs b/src/Language/Haskell/Liquid/Bare/ToBare.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/ToBare.hs
+++ /dev/null
@@ -1,90 +0,0 @@
--- | This module contains functions that convert things
--- to their `Bare` versions, e.g. SpecType -> BareType etc.
-
-module Language.Haskell.Liquid.Bare.ToBare
- ( -- * Types
- specToBare
-
- -- * Measures
- , measureToBare
- )
- where
-
-import DataCon
-import Data.Bifunctor
-
-import Language.Fixpoint.Misc (mapSnd)
-import qualified Language.Fixpoint.Types as F
-import Language.Haskell.Liquid.GHC.Misc
-import Language.Haskell.Liquid.Types
--- import Language.Haskell.Liquid.Measure
--- import Language.Haskell.Liquid.Types.RefType
-
---------------------------------------------------------------------------------
-specToBare :: SpecType -> BareType
---------------------------------------------------------------------------------
-specToBare = txRType specToBareTC specToBareTV
-
--- specToBare t = F.tracepp ("specToBare t2 = " ++ F.showpp t2) t1
- -- where
- -- t1 = bareOfType . toType $ t
- -- t2 = _specToBare t
-
-
---------------------------------------------------------------------------------
-measureToBare :: SpecMeasure -> BareMeasure
---------------------------------------------------------------------------------
-measureToBare = bimap (fmap specToBare) dataConToBare
-
-dataConToBare :: DataCon -> LocSymbol
-dataConToBare d = (dropModuleNames . F.symbol) <$> locNamedThing d
- where
- _msg = "dataConToBare dc = " ++ show d ++ " v = " ++ show v ++ " vx = " ++ show vx
- v = dataConWorkId d
- vx = F.symbol v
-
-specToBareTC :: RTyCon -> BTyCon
-specToBareTC = tyConBTyCon . rtc_tc
-
-specToBareTV :: RTyVar -> BTyVar
-specToBareTV (RTV α) = BTV (F.symbol α)
-
-txRType :: (c1 -> c2) -> (tv1 -> tv2) -> RType c1 tv1 r -> RType c2 tv2 r
-txRType cF vF = go
- where
- -- go :: RType c1 tv1 r -> RType c2 tv2 r
- go (RVar α r) = RVar (vF α) r
- go (RAllT α t r) = RAllT (goRTV α) (go t) r
- go (RAllP π t) = RAllP (goPV π) (go t)
- go (RImpF x t t' r) = RImpF x (go t) (go t') r
- go (RFun x t t' r) = RFun x (go t) (go t') r
- go (RAllE x t t') = RAllE x (go t) (go t')
- go (REx x t t') = REx x (go t) (go t')
- go (RAppTy t t' r) = RAppTy (go t) (go t') r
- go (RApp c ts rs r) = RApp (cF c) (go <$> ts) (goRTP <$> rs) r
- go (RRTy xts r o t) = RRTy (mapSnd go <$> xts) r o (go t)
- go (RExprArg e) = RExprArg e
- go (RHole r) = RHole r
-
- -- go' :: RType c1 tv1 () -> RType c2 tv2 ()
- go' = txRType cF vF
-
- -- goRTP :: RTProp c1 tv1 r -> RTProp c2 tv2 r
- goRTP (RProp s (RHole r)) = RProp (mapSnd go' <$> s) (RHole r)
- goRTP (RProp s t) = RProp (mapSnd go' <$> s) (go t)
-
- -- goRTV :: RTVU c1 tv1 -> RTVU c2 tv2
- goRTV = txRTV cF vF
-
- -- goPV :: PVU c1 tv1 -> PVU c2 tv2
- goPV = txPV cF vF
-
-txRTV :: (c1 -> c2) -> (tv1 -> tv2) -> RTVU c1 tv1 -> RTVU c2 tv2
-txRTV cF vF (RTVar α z) = RTVar (vF α) (txRType cF vF <$> z)
-
-txPV :: (c1 -> c2) -> (tv1 -> tv2) -> PVU c1 tv1 -> PVU c2 tv2
-txPV cF vF (PV x k y txes) = PV x k' y txes'
- where
- txes' = [ (tx t, x, e) | (t, x, e) <- txes]
- k' = tx <$> k
- tx = txRType cF vF
diff --git a/src/Language/Haskell/Liquid/Bare/Types.hs b/src/Language/Haskell/Liquid/Bare/Types.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Bare/Types.hs
+++ /dev/null
@@ -1,156 +0,0 @@
--- | This module has the code that uses the GHC definitions to:
--- 1. MAKE a name-resolution environment,
--- 2. USE the environment to translate plain symbols into Var, TyCon, etc.
-
-module Language.Haskell.Liquid.Bare.Types
- ( -- * Name resolution environment
- Env (..)
- , TyThingMap
- , ModSpecs
- , LocalVars
-
- -- * Tycon and Datacon processing environment
- , TycEnv (..)
- , DataConMap
- , RT.TyConMap
-
- -- * Signature processing environment
- , SigEnv (..)
-
- -- * Measure related environment
- , MeasEnv (..)
-
- -- * Misc
- , PlugTV (..)
- , plugSrc
- , varRSort
- , varSortedReft
- , failMaybe
- ) where
-
-import qualified Control.Exception as Ex
-import qualified Text.PrettyPrint.HughesPJ as PJ
-import qualified Data.HashSet as S
-import qualified Data.HashMap.Strict as M
-import qualified Language.Fixpoint.Types as F
-import qualified Language.Haskell.Liquid.Measure as Ms
-import qualified Language.Haskell.Liquid.Types.RefType as RT
-import Language.Haskell.Liquid.Types.Types
-import Language.Haskell.Liquid.Types.Specs hiding (BareSpec)
-import Language.Haskell.Liquid.GHC.API as Ghc hiding (Located)
-import Language.Haskell.Liquid.GHC.Types (StableName)
-
-
-type ModSpecs = M.HashMap ModName Ms.BareSpec
-
--------------------------------------------------------------------------------
--- | See [NOTE: Plug-Holes-TyVars] for a rationale for @PlugTV@
--------------------------------------------------------------------------------
-
-data PlugTV v
- = HsTV v -- ^ Use tyvars from GHC specification (in the `v`)
- | LqTV v -- ^ Use tyvars from Liquid specification
- | GenTV -- ^ Generalize ty-vars
- | RawTV -- ^ Do NOT generalize ty-vars (e.g. for type-aliases)
- deriving (Show)
-
-
-instance (Show v, F.PPrint v) => F.PPrint (PlugTV v) where
- pprintTidy _ = PJ.text . show
-
-plugSrc :: PlugTV v -> Maybe v
-plugSrc (HsTV v) = Just v
-plugSrc (LqTV v) = Just v
-plugSrc _ = Nothing
-
--------------------------------------------------------------------------------
--- | Name resolution environment
--------------------------------------------------------------------------------
-data Env = RE
- { reLMap :: !LogicMap
- , reSyms :: ![(F.Symbol, Ghc.Var)] -- ^ see "syms" in old makeGhcSpec'
- , _reSubst :: !F.Subst -- ^ see "su" in old makeGhcSpec'
- , _reTyThings :: !TyThingMap
- , reCfg :: !Config
- , reQualImps :: !QImports -- ^ qualified imports
- , reAllImps :: !(S.HashSet F.Symbol) -- ^ all imported modules
- , reLocalVars :: !LocalVars -- ^ lines at which local variables are defined.
- , reGlobSyms :: !(S.HashSet F.Symbol) -- ^ global symbols, typically unlifted measures like 'len', 'fromJust'
- , reSrc :: !GhcSrc -- ^ all source info
- }
-
-instance HasConfig Env where
- getConfig = reCfg
-
--- | @LocalVars@ is a map from names to lists of pairs of @Ghc.Var@ and
--- the lines at which they were defined.
-type LocalVars = M.HashMap F.Symbol [(Int, Ghc.Var)]
-
--------------------------------------------------------------------------------
--- | A @TyThingMap@ is used to resolve symbols into GHC @TyThing@ and,
--- from there into Var, TyCon, DataCon, etc.
--------------------------------------------------------------------------------
-type TyThingMap = M.HashMap F.Symbol [(F.Symbol, Ghc.TyThing)]
-
--------------------------------------------------------------------------------
--- | A @SigEnv@ contains the needed to process type signatures
--------------------------------------------------------------------------------
-data SigEnv = SigEnv
- { sigEmbs :: !(F.TCEmb Ghc.TyCon)
- , sigTyRTyMap :: !RT.TyConMap
- , sigExports :: !(S.HashSet StableName)
- , sigRTEnv :: !BareRTEnv
- }
-
--------------------------------------------------------------------------------
--- | A @TycEnv@ contains the information needed to process Type- and Data- Constructors
--------------------------------------------------------------------------------
-data TycEnv = TycEnv
- { tcTyCons :: ![TyConP]
- , tcDataCons :: ![DataConP]
- , tcSelMeasures :: ![Measure SpecType Ghc.DataCon]
- , tcSelVars :: ![(Ghc.Var, LocSpecType)]
- , tcTyConMap :: !RT.TyConMap
- , tcAdts :: ![F.DataDecl]
- , tcDataConMap :: !DataConMap
- , tcEmbs :: !(F.TCEmb Ghc.TyCon)
- , tcName :: !ModName
- }
-
-type DataConMap = M.HashMap (F.Symbol, Int) F.Symbol
-
--------------------------------------------------------------------------------
--- | Intermediate representation for Measure information
--------------------------------------------------------------------------------
--- REBARE: used to be output of makeGhcSpecCHOP2
-data MeasEnv = MeasEnv
- { meMeasureSpec :: !(MSpec SpecType Ghc.DataCon)
- , meClassSyms :: ![(F.Symbol, Located (RRType F.Reft))]
- , meSyms :: ![(F.Symbol, Located (RRType F.Reft))]
- , meDataCons :: ![(Ghc.Var, LocSpecType)]
- , meClasses :: ![DataConP]
- , meMethods :: ![(ModName, Ghc.Var, LocSpecType)]
- , meCLaws :: !([(Ghc.Class, [(ModName, Ghc.Var, LocSpecType)])])
- }
-
--------------------------------------------------------------------------------
--- | Converting @Var@ to @Sort@
--------------------------------------------------------------------------------
-varSortedReft :: F.TCEmb Ghc.TyCon -> Ghc.Var -> F.SortedReft
-varSortedReft emb = RT.rTypeSortedReft emb . varRSort
-
-varRSort :: Ghc.Var -> RSort
-varRSort = RT.ofType . Ghc.varType
-
--------------------------------------------------------------------------------
--- | Handling failed resolution
--------------------------------------------------------------------------------
-failMaybe :: Env -> ModName -> Either UserError r -> Maybe r
-failMaybe env name res = case res of
- Right r -> Just r
- Left e -> if isTargetModName env name
- then Ex.throw e
- else Nothing
-
-isTargetModName :: Env -> ModName -> Bool
-isTargetModName env name = name == _giTargetMod (reSrc env)
diff --git a/src/Language/Haskell/Liquid/Cabal.hs b/src/Language/Haskell/Liquid/Cabal.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Cabal.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{- | This module provides a drop-in replacement for Cabal's 'defaultMain', to be used inside 'Setup.hs'
- modules of packages that wants to use the \"dev mode\". For more information, visit the documentation,
- especially the \"Developers' guide\".
--}
-
-{-# LANGUAGE LambdaCase #-}
-module Language.Haskell.Liquid.Cabal (liquidHaskellMain) where
-
-import Distribution.Simple
-import System.Environment
-
-liquidHaskellMain :: IO ()
-liquidHaskellMain = do
- mbDevMode <- lookupEnv "LIQUID_DEV_MODE"
- defaultMainWithHooks (devModeHooks mbDevMode)
-
-devModeHooks :: Maybe String -> UserHooks
-devModeHooks = \case
- Nothing -> simpleUserHooks
- Just x | x == "false" -> simpleUserHooks
- Just _ -> simpleUserHooks { buildHook = \_ _ _ _ -> return () }
diff --git a/src/Language/Haskell/Liquid/Constraint/Constraint.hs b/src/Language/Haskell/Liquid/Constraint/Constraint.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/Constraint.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-
--- TODO: what exactly is the purpose of this module? What do these functions do?
-
-module Language.Haskell.Liquid.Constraint.Constraint (
- constraintToLogic
-, addConstraints
-) where
-
-import Prelude hiding (error)
-import Data.Maybe
-import Language.Haskell.Liquid.Types
-import Language.Haskell.Liquid.Constraint.Types
-import Language.Haskell.Liquid.Constraint.Env
-import Language.Fixpoint.Types
-
---------------------------------------------------------------------------------
-addConstraints :: CGEnv -> [(Symbol, SpecType)] -> CGEnv
---------------------------------------------------------------------------------
-addConstraints γ t = γ {lcs = mappend (t2c t) (lcs γ)}
- where
- t2c z = LC [z]
-
---------------------------------------------------------------------------------
-constraintToLogic :: REnv -> LConstraint -> Expr
---------------------------------------------------------------------------------
-constraintToLogic γ (LC ts) = pAnd (constraintToLogicOne γ <$> ts)
-
--- RJ: The code below is atrocious. Please fix it!
-constraintToLogicOne :: (Reftable r) => REnv -> [(Symbol, RRType r)] -> Expr
-constraintToLogicOne γ binds
- = pAnd [subConstraintToLogicOne
- (zip xs xts)
- (last xs,
- (last (fst <$> xts), r))
- | xts <- xss]
- where
- xts = init binds
- (xs, ts) = unzip xts
- r = snd $ last binds
- xss = combinations ((\t -> [(x, t) | x <- localBindsOfType t γ]) <$> ts)
-
-subConstraintToLogicOne :: (Foldable t, Reftable r, Reftable r1)
- => t (Symbol, (Symbol, RType t1 t2 r))
- -> (Symbol, (Symbol, RType t3 t4 r1)) -> Expr
-subConstraintToLogicOne xts (x', (x, t)) = PImp (pAnd rs) r
- where
- (rs , su) = foldl go ([], []) xts
- ([r], _ ) = go ([], su) (x', (x, t))
- go (acc, su) (x', (x, t)) = let (Reft(v, p)) = toReft (fromMaybe mempty (stripRTypeBase t))
- su' = (x', EVar x):(v, EVar x) : su
- in
- (subst (mkSubst su') p : acc, su')
-
-combinations :: [[a]] -> [[a]]
-combinations [] = [[]]
-combinations ([]:_) = []
-combinations ((y:ys):yss) = [y:xs | xs <- combinations yss] ++ combinations (ys:yss)
diff --git a/src/Language/Haskell/Liquid/Constraint/Env.hs b/src/Language/Haskell/Liquid/Constraint/Env.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/Env.hs
+++ /dev/null
@@ -1,301 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-
--- | This module defines the representation for Environments needed
--- during constraint generation.
-
-module Language.Haskell.Liquid.Constraint.Env (
-
- -- * Insert
- (+++=)
- -- , (++=)
- , (+=)
- , extendEnvWithVV
- , addBinders
- , addSEnv
- , addEEnv
- , (-=)
- , globalize
-
- -- * Construction
- , fromListREnv
- , toListREnv
- , insertREnv -- TODO: remove this ASAP
-
- -- * Query
- , localBindsOfType
- , lookupREnv
- , (?=)
-
- -- * Pruning refinements (TODO: move!)
- , rTypeSortedReft'
-
- -- * Extend CGEnv
- , setLocation, setBind, setRecs, setTRec
-
- -- * Lookup CGEnv
- , getLocation
-
-) where
-
-
--- import Name (getSrcSpan)
-import Prelude hiding (error)
-import CoreSyn (CoreExpr)
-import SrcLoc
-import Var
--- import Outputable
--- import FastString (fsLit)
-import Control.Monad.State
-
--- import GHC.Err.Located hiding (error)
-import GHC.Stack
-
-import Control.Arrow (first)
-import Data.Maybe -- (fromMaybe)
-import qualified Data.List as L
-import qualified Data.HashSet as S
-import qualified Data.HashMap.Strict as M
-import qualified Language.Fixpoint.Types as F
-
-
-import Language.Fixpoint.SortCheck (pruneUnsortedReft)
-
-
-
-import Language.Haskell.Liquid.Types.RefType
-import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp
-import Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars, Def)
-import Language.Haskell.Liquid.Constraint.Types
-import Language.Haskell.Liquid.Constraint.Fresh ()
-import Language.Haskell.Liquid.Transforms.RefSplit
-import qualified Language.Haskell.Liquid.UX.CTags as Tg
-
--- import Debug.Trace (trace)
---------------------------------------------------------------------------------
--- | Refinement Type Environments ----------------------------------------------
---------------------------------------------------------------------------------
-
--- updREnvLocal :: REnv -> (_ -> _) -> REnv
-updREnvLocal :: REnv
- -> (M.HashMap F.Symbol SpecType -> M.HashMap F.Symbol SpecType)
- -> REnv
-updREnvLocal rE f = rE { reLocal = f (reLocal rE) }
-
--- RJ: REnv-Split-Bug?
-filterREnv :: (SpecType -> Bool) -> REnv -> REnv
-filterREnv f rE = rE `updREnvLocal` (M.filter f)
-
-fromListREnv :: [(F.Symbol, SpecType)] -> [(F.Symbol, SpecType)] -> REnv
-fromListREnv gXts lXts = REnv
- { reGlobal = M.fromList gXts
- , reLocal = M.fromList lXts
- }
-
--- RJ: REnv-Split-Bug?
-deleteREnv :: F.Symbol -> REnv -> REnv
-deleteREnv x rE = rE `updREnvLocal` (M.delete x)
-
-insertREnv :: F.Symbol -> SpecType -> REnv -> REnv
-insertREnv x y rE = {- trace ("insertREnv: " ++ show x) $ -} rE `updREnvLocal` (M.insert x y)
-
-lookupREnv :: F.Symbol -> REnv -> Maybe SpecType
-lookupREnv x rE = msum $ M.lookup x <$> renvMaps rE
-
-memberREnv :: F.Symbol -> REnv -> Bool
-memberREnv x rE = or $ M.member x <$> renvMaps rE
-
-globalREnv :: REnv -> REnv
-globalREnv (REnv gM lM) = REnv gM' M.empty
- where
- gM' = M.unionWith (\_ t -> t) gM lM
-
-renvMaps :: REnv -> [M.HashMap F.Symbol SpecType]
-renvMaps rE = [reLocal rE, reGlobal rE]
-
---------------------------------------------------------------------------------
-localBindsOfType :: RRType r -> REnv -> [F.Symbol]
---------------------------------------------------------------------------------
-localBindsOfType tx γ = fst <$> localsREnv (filterREnv ((== toRSort tx) . toRSort) γ)
-
--- RJ: REnv-Split-Bug?
-localsREnv :: REnv -> [(F.Symbol, SpecType)]
-localsREnv = M.toList . reLocal
-
-globalsREnv :: REnv -> [(F.Symbol, SpecType)]
-globalsREnv = M.toList . reGlobal
-
-toListREnv :: REnv -> [(F.Symbol, SpecType)]
-toListREnv re = globalsREnv re ++ localsREnv re
-
---------------------------------------------------------------------------------
-extendEnvWithVV :: CGEnv -> SpecType -> CG CGEnv
---------------------------------------------------------------------------------
-extendEnvWithVV γ t
- | F.isNontrivialVV vv && not (vv `memberREnv` (renv γ))
- = γ += ("extVV", vv, t)
- | otherwise
- = return γ
- where
- vv = rTypeValueVar t
-
-addBinders :: CGEnv -> F.Symbol -> [(F.Symbol, SpecType)] -> CG CGEnv
-addBinders γ0 x' cbs = foldM (++=) (γ0 -= x') [("addBinders", x, t) | (x, t) <- cbs]
-
-addBind :: SrcSpan -> F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId)
-addBind l x r = do
- st <- get
- let (i, bs') = F.insertBindEnv x r (binds st)
- put $ st { binds = bs' } { bindSpans = M.insert i l (bindSpans st) }
- return ((x, F.sr_sort r), {- traceShow ("addBind: " ++ showpp x) -} i)
-
-addClassBind :: CGEnv -> SrcSpan -> SpecType -> CG [((F.Symbol, F.Sort), F.BindId)]
-addClassBind γ l = mapM (uncurry (addBind l)) . classBinds (emb γ)
-
-{- see tests/pos/polyfun for why you need everything in fixenv -}
-addCGEnv :: (SpecType -> SpecType) -> CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv
-addCGEnv tx γ (eMsg, x, REx y tyy tyx) = do
- y' <- fresh
- γ' <- addCGEnv tx γ (eMsg, y', tyy)
- addCGEnv tx γ' (eMsg, x, tyx `F.subst1` (y, F.EVar y'))
-
-addCGEnv tx γ (eMsg, x, RAllE yy tyy tyx)
- = addCGEnv tx γ (eMsg, x, t)
- where
- xs = localBindsOfType tyy (renv γ)
- t = L.foldl' F.meet ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs]
- (tyx', ttrue) = splitXRelatedRefs yy tyx
-
-addCGEnv tx γ (_, x, t') = do
- idx <- fresh
- -- allowHOBinders <- allowHO <$> get
- let t = tx $ normalize idx t'
- let l = getLocation γ
- let γ' = γ { renv = insertREnv x t (renv γ) }
- tem <- getTemplates
- is <- (:) <$> addBind l x (rTypeSortedReft' γ' tem t) <*> addClassBind γ' l t
- return $ γ' { fenv = insertsFEnv (fenv γ) is }
-
-rTypeSortedReft' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))
- => CGEnv -> F.Templates -> RRType r -> F.SortedReft
-rTypeSortedReft' γ t
- = pruneUnsortedReft (feEnv $ fenv γ) t . f
- where
- f = rTypeSortedReft (emb γ)
-
-
-normalize :: Integer -> SpecType -> SpecType
-normalize idx = normalizeVV idx . normalizePds
-
-normalizeVV :: Integer -> SpecType -> SpecType
-normalizeVV idx t@(RApp _ _ _ _)
- | not (F.isNontrivialVV (rTypeValueVar t))
- = shiftVV t (F.vv $ Just idx)
-
-normalizeVV _ t
- = t
-
---------------------------------------------------------------------------------
-(+=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv
---------------------------------------------------------------------------------
-γ += (eMsg, x, r)
- | x == F.dummySymbol
- = return γ
- -- // | x `memberREnv` (renv γ)
- -- // = _dupBindErr x γ
- | otherwise
- = γ ++= (eMsg, x, r)
-
-_dupBindError :: String -> F.Symbol -> CGEnv -> SpecType -> a
-_dupBindError eMsg x γ r = panic Nothing s
- where
- s = unlines [ eMsg ++ " Duplicate binding for " ++ F.symbolString x
- , " New: " ++ showpp r
- , " Old: " ++ showpp (x `lookupREnv` (renv γ)) ]
-
---------------------------------------------------------------------------------
-globalize :: CGEnv -> CGEnv
---------------------------------------------------------------------------------
-globalize γ = γ {renv = globalREnv (renv γ)}
-
---------------------------------------------------------------------------------
-(++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv
---------------------------------------------------------------------------------
-(++=) γ (eMsg, x, t)
- = addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ (eMsg, x, t)
-
---------------------------------------------------------------------------------
-addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv
---------------------------------------------------------------------------------
-addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ
-
-addEEnv :: CGEnv -> (F.Symbol, SpecType) -> CG CGEnv
-addEEnv γ (x,t')= do
- idx <- fresh
- -- allowHOBinders <- allowHO <$> get
- let t = addRTyConInv (invs γ) $ normalize idx t'
- let l = getLocation γ
- let γ' = γ { renv = insertREnv x t (renv γ) }
- tem <- getTemplates
- is <- (:) <$> addBind l x (rTypeSortedReft' γ' tem t) <*> addClassBind γ' l t
- modify (\s -> s { ebinds = ebinds s ++ (snd <$> is)})
- return $ γ' { fenv = insertsFEnv (fenv γ) is }
-
-
-(+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv
-(γ, _) +++= (x, e, t) = (γ {lcb = M.insert x e (lcb γ) }) += ("+++=", x, t)
-
-(-=) :: CGEnv -> F.Symbol -> CGEnv
-γ -= x = γ { renv = deleteREnv x (renv γ)
- , lcb = M.delete x (lcb γ)
- -- , fenv = removeFEnv x (fenv γ)
- }
-
-(?=) :: (?callStack :: CallStack) => CGEnv -> F.Symbol -> Maybe SpecType
-γ ?= x = lookupREnv x (renv γ)
-
-------------------------------------------------------------------------
-setLocation :: CGEnv -> Sp.Span -> CGEnv
-------------------------------------------------------------------------
-setLocation γ p = γ { cgLoc = Sp.push p $ cgLoc γ }
-
-------------------------------------------------------------------------
-setBind :: CGEnv -> Var -> CGEnv
-------------------------------------------------------------------------
-setBind γ x = γ `setLocation` Sp.Var x `setBind'` x
-
-setBind' :: CGEnv -> Tg.TagKey -> CGEnv
-setBind' γ k
- | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k }
- | otherwise = γ
-
-------------------------------------------------------------------------
-setRecs :: CGEnv -> [Var] -> CGEnv
-------------------------------------------------------------------------
-setRecs γ xs = γ { recs = L.foldl' (flip S.insert) (recs γ) xs }
-
-------------------------------------------------------------------------
-setTRec :: CGEnv -> [(Var, SpecType)] -> CGEnv
-------------------------------------------------------------------------
-setTRec γ xts = γ' {trec = Just $ M.fromList xts' `M.union` trec'}
- where
- γ' = γ `setRecs` (fst <$> xts)
- trec' = fromMaybe M.empty $ trec γ
- xts' = first F.symbol <$> xts
-
-------------------------------------------------------------------------
-getLocation :: CGEnv -> SrcSpan
-------------------------------------------------------------------------
-getLocation = Sp.srcSpan . cgLoc
diff --git a/src/Language/Haskell/Liquid/Constraint/Fresh.hs b/src/Language/Haskell/Liquid/Constraint/Fresh.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/Fresh.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ConstraintKinds #-}
-
-module Language.Haskell.Liquid.Constraint.Fresh
- ( -- module Language.Haskell.Liquid.Types.Fresh
- -- ,
- refreshArgsTop
- , freshTy_type
- , freshTy_expr
- , trueTy
- , addKuts
- )
- where
-
--- import Data.Maybe (catMaybes) -- , fromJust, isJust)
--- import Data.Bifunctor
--- import qualified Data.List as L
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-import Data.Hashable
-import Control.Monad.State (gets, get, put, modify)
-import Control.Monad (when, (>=>))
-import Prelude hiding (error)
-
-import CoreUtils (exprType)
-import Type (Type)
-import CoreSyn
-import Var (varType, isTyVar, Var)
-
-import Language.Fixpoint.Misc ((=>>))
-import qualified Language.Fixpoint.Types as F
-import Language.Fixpoint.Types.Visitor (kvars)
-import Language.Haskell.Liquid.Types
--- import Language.Haskell.Liquid.Types.RefType
--- import Language.Haskell.Liquid.Types.Fresh
-import Language.Haskell.Liquid.Constraint.Types
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-
---------------------------------------------------------------------------------
--- | This is all hardwiring stuff to CG ----------------------------------------
---------------------------------------------------------------------------------
-instance Freshable CG Integer where
- fresh = do s <- get
- let n = freshIndex s
- put $ s { freshIndex = n + 1 }
- return n
-
---------------------------------------------------------------------------------
-refreshArgsTop :: (Var, SpecType) -> CG SpecType
---------------------------------------------------------------------------------
-refreshArgsTop (x, t)
- = do (t', su) <- refreshArgsSub t
- modify $ \s -> s {termExprs = M.adjust (F.subst su <$>) x $ termExprs s}
- return t'
-
---------------------------------------------------------------------------------
--- | Generation: Freshness -----------------------------------------------------
---------------------------------------------------------------------------------
-
--- | Right now, we generate NO new pvars. Rather than clutter code
--- with `uRType` calls, put it in one place where the above
--- invariant is /obviously/ enforced.
--- Constraint generation should ONLY use @freshTy_type@ and @freshTy_expr@
-
-freshTy_type :: KVKind -> CoreExpr -> Type -> CG SpecType
-freshTy_type k e τ = F.notracepp ("freshTy_type: " ++ F.showpp k ++ GM.showPpr e)
- <$> freshTy_reftype k (ofType τ)
-
-freshTy_expr :: KVKind -> CoreExpr -> Type -> CG SpecType
-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
-
--- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive
--- definitions, and also to update the KVar profile.
-addKVars :: KVKind -> SpecType -> CG ()
-addKVars !k !t = do
- cfg <- getConfig <$> gets ghcI
- when (True) $ modify $ \s -> s { kvProf = updKVProf k ks (kvProf s) }
- when (isKut cfg k) $ addKuts k t
- where
- ks = F.KS $ S.fromList $ specTypeKVars t
-
-isKut :: Config -> KVKind -> Bool
-isKut _ (RecBindE _) = True
-isKut cfg ProjectE = not (higherOrderFlag cfg) -- see ISSUE 1034, tests/pos/T1034.hs
-isKut _ _ = False
-
-addKuts :: (PPrint a) => a -> SpecType -> CG ()
-addKuts _x t = modify $ \s -> s { kuts = mappend (F.KS ks) (kuts s) }
- where
- ks' = S.fromList $ specTypeKVars t
- ks
- | S.null ks' = ks'
- | otherwise = {- F.tracepp ("addKuts: " ++ showpp _x) -} ks'
-
-specTypeKVars :: SpecType -> [F.KVar]
-specTypeKVars = foldReft False (\ _ r ks -> (kvars $ ur_reft r) ++ ks) []
-
---------------------------------------------------------------------------------
-trueTy :: Type -> CG SpecType
---------------------------------------------------------------------------------
-trueTy = ofType' >=> true
-
-ofType' :: Type -> CG SpecType
-ofType' = fixTy . ofType
-
-fixTy :: SpecType -> CG SpecType
-fixTy t = do tyi <- tyConInfo <$> get
- tce <- tyConEmbed <$> get
- return $ addTyConInfo tce tyi t
-
-exprRefType :: CoreExpr -> SpecType
-exprRefType = exprRefType_ M.empty
-
-exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType
-exprRefType_ γ (Let b e)
- = exprRefType_ (bindRefType_ γ b) e
-
-exprRefType_ γ (Lam α e) | isTyVar α
- = RAllT (makeRTVar $ rTyVar α) (exprRefType_ γ e) mempty
-
-exprRefType_ γ (Lam x e)
- = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e)
-
-exprRefType_ γ (Tick _ e)
- = exprRefType_ γ e
-
-exprRefType_ γ (Var x)
- = M.lookupDefault (ofType $ varType x) x γ
-
-exprRefType_ _ e
- = ofType $ exprType e
-
-bindRefType_ :: M.HashMap Var SpecType -> Bind Var -> M.HashMap Var SpecType
-bindRefType_ γ (Rec xes)
- = extendγ γ [(x, exprRefType_ γ e) | (x,e) <- xes]
-
-bindRefType_ γ (NonRec x e)
- = extendγ γ [(x, exprRefType_ γ e)]
-
-extendγ :: (Eq k, Foldable t, Hashable k)
- => M.HashMap k v
- -> t (k, v)
- -> M.HashMap k v
-extendγ γ xts
- = foldr (\(x,t) m -> M.insert x t m) γ xts
diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/Generate.hs
+++ /dev/null
@@ -1,1467 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImplicitParams #-}
-
--- | This module defines the representation of Subtyping and WF Constraints,
--- and the code for syntax-directed constraint generation.
-
-module Language.Haskell.Liquid.Constraint.Generate ( generateConstraints, generateConstraintsWithEnv, caseEnv, consE ) where
-
-#if !MIN_VERSION_base(4,14,0)
-import Control.Monad.Fail
-#endif
-
-import Outputable (Outputable)
-import Prelude hiding (error)
-import GHC.Stack
-import CoreUtils (exprType)
-import MkCore
-import Coercion
-import DataCon
-import Pair
-import CoreSyn
-import SrcLoc hiding (Located)
-import Type
-import VarEnv (mkRnEnv2, emptyInScopeSet)
-import TyCon
-import CoAxiom
-import PrelNames
-import Language.Haskell.Liquid.GHC.API as Ghc hiding (exprType)
-import Language.Haskell.Liquid.GHC.TypeRep ()
-import IdInfo
-import Unify
-import UniqSet (mkUniqSet)
-import Text.PrettyPrint.HughesPJ hiding ((<>))
-import Control.Monad.State
-import Data.Maybe (fromMaybe, catMaybes, isJust)
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-import qualified Data.List as L
-import qualified Data.Foldable as F
-import qualified Data.Traversable as T
-import qualified Data.Functor.Identity
-import Language.Fixpoint.Misc
-import Language.Fixpoint.Types.Visitor
-import qualified Language.Fixpoint.Types as F
-import qualified Language.Fixpoint.Types.Visitor as F
-import Language.Haskell.Liquid.Constraint.Fresh
-import Language.Haskell.Liquid.Constraint.Init
-import Language.Haskell.Liquid.Constraint.Env
-import Language.Haskell.Liquid.Constraint.Monad
-import Language.Haskell.Liquid.Constraint.Split
-import Language.Haskell.Liquid.Types.Dictionaries
-import Language.Haskell.Liquid.GHC.Play (isHoleVar)
-import qualified Language.Haskell.Liquid.GHC.Resugar as Rs
-import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp
-import qualified Language.Haskell.Liquid.GHC.Misc as GM -- ( isInternal, collectArguments, tickSrcSpan, showPpr )
-import Language.Haskell.Liquid.Misc
-import Language.Haskell.Liquid.Constraint.Types
-import Language.Haskell.Liquid.Constraint.Constraint
-import Language.Haskell.Liquid.Transforms.Rec
-import Language.Haskell.Liquid.Transforms.CoreToLogic (weakenResult)
-import Language.Haskell.Liquid.Bare.DataType (makeDataConChecker)
-
-import Language.Haskell.Liquid.Types hiding (binds, Loc, loc, Def)
-
---------------------------------------------------------------------------------
--- | Constraint Generation: Toplevel -------------------------------------------
---------------------------------------------------------------------------------
-generateConstraints :: TargetInfo -> CGInfo
---------------------------------------------------------------------------------
-generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info
- where
- act = do { γ <- initEnv info; consAct γ cfg info }
- cfg = getConfig info
-
-generateConstraintsWithEnv :: TargetInfo -> CGInfo -> CGEnv -> CGInfo
---------------------------------------------------------------------------------
-generateConstraintsWithEnv info cgi γ = {-# SCC "ConsGenEnv" #-} execState act cgi
- where
- act = consAct γ cfg info
- cfg = getConfig info
-
-consAct :: CGEnv -> Config -> TargetInfo -> CG ()
-consAct γ cfg info = do
- let sSpc = gsSig . giSpec $ info
- let gSrc = giSrc info
- when (gradual cfg) (mapM_ (addW . WfC γ . val . snd) (gsTySigs sSpc ++ gsAsmSigs sSpc))
- foldM_ (consCBTop cfg info) γ (giCbs gSrc)
- mapM (consClass γ) (gsMethods $ gsSig $ giSpec info)
- hcs <- hsCs <$> get
- hws <- hsWfs <$> get
- fcs <- concat <$> mapM splitC hcs
- fws <- concat <$> mapM splitW hws
- modify $ \st -> st { fEnv = feEnv (fenv γ)
- , cgLits = litEnv γ
- , cgConsts = (cgConsts st) `mappend` (constEnv γ)
- , fixCs = fcs
- , fixWfs = fws }
-
-
-
---------------------------------------------------------------------------------
--- | Ensure that the instance type is a subtype of the class type --------------
---------------------------------------------------------------------------------
-
-consClass :: CGEnv -> (Var, MethodType LocSpecType) -> CG ()
-consClass γ (x,mt)
- | Just ti <- tyInstance mt
- , Just tc <- tyClass mt
- = addC (SubC (γ `setLocation` Sp.Span (GM.fSrcSpan (F.loc ti))) (val ti) (val tc)) ("cconsClass for " ++ GM.showPpr x)
-consClass _ _
- = return ()
-
---------------------------------------------------------------------------------
--- | TERMINATION TYPE ----------------------------------------------------------
---------------------------------------------------------------------------------
-makeDecrIndex :: (Var, Template SpecType, [Var]) -> CG [Int]
-makeDecrIndex (x, Assumed t, args)
- = do dindex <- makeDecrIndexTy x t args
- case dindex of
- Left _ -> return []
- Right i -> return i
-makeDecrIndex (x, Asserted t, args)
- = do dindex <- makeDecrIndexTy x t args
- case dindex of
- Left msg -> addWarning msg >> return []
- Right i -> return i
-makeDecrIndex _ = return []
-
-makeDecrIndexTy :: Var -> SpecType -> [Var] -> CG (Either (TError t) [Int])
-makeDecrIndexTy x t args
- = do spDecr <- specDecr <$> get
- autosz <- autoSize <$> get
- hint <- checkHint' autosz (L.lookup x spDecr)
- case dindex autosz of
- Nothing -> return $ Left msg
- Just i -> return $ Right $ fromMaybe [i] hint
- where
- ts = ty_args trep
- tvs = zip ts args
- checkHint' = \autosz -> checkHint x ts (isDecreasing autosz cenv)
- dindex = \autosz -> L.findIndex (p autosz) tvs
- p autosz (t, v) = isDecreasing autosz cenv t && not (isIdTRecBound v)
- msg = ErrTermin (getSrcSpan x) [F.pprint x] (text "No decreasing parameter")
- cenv = makeNumEnv ts
- trep = toRTypeRep $ unOCons t
-
-
-recType :: F.Symbolic a
- => S.HashSet TyCon
- -> (([a], [Int]), (t, [Int], SpecType))
- -> SpecType
-recType _ ((_, []), (_, [], t))
- = t
-
-recType autoenv ((vs, indexc), (_, index, t))
- = makeRecType autoenv t v dxt index
- where v = (vs !!) <$> indexc
- dxt = (xts !!) <$> index
- xts = zip (ty_binds trep) (ty_args trep)
- trep = toRTypeRep $ unOCons t
-
-checkIndex :: (NamedThing t, PPrint t, PPrint a)
- => (t, [a], Template (RType c tv r), [Int])
- -> CG [Maybe (RType c tv r)]
-checkIndex (x, vs, t, index)
- = do mapM_ (safeLogIndex msg1 vs) index
- mapM (safeLogIndex msg2 ts) index
- where
- loc = getSrcSpan x
- ts = ty_args $ toRTypeRep $ unOCons $ unTemplate t
- msg1 = ErrTermin loc [xd] ("No decreasing" <+> F.pprint index <-> "-th argument on" <+> xd <+> "with" <+> (F.pprint vs))
- msg2 = ErrTermin loc [xd] "No decreasing parameter"
- xd = F.pprint x
-
-makeRecType :: (Enum a1, Eq a1, Num a1, F.Symbolic a)
- => S.HashSet TyCon
- -> SpecType
- -> [a]
- -> [(F.Symbol, SpecType)]
- -> [a1]
- -> SpecType
-makeRecType autoenv t vs dxs is
- = mergecondition t $ fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}
- where
- (xs', ts') = unzip $ replaceN (last is) (safeFromLeft "makeRecType" $ makeDecrType autoenv vdxs) xts
- vdxs = zip vs dxs
- xts = zip (ty_binds trep) (ty_args trep)
- trep = toRTypeRep $ unOCons t
-
-unOCons :: RType c tv r -> RType c tv r
-unOCons (RAllT v t r) = RAllT v (unOCons t) r
-unOCons (RAllP p t) = RAllP p $ unOCons t
-unOCons (RFun x tx t r) = RFun x (unOCons tx) (unOCons t) r
-unOCons (RRTy _ _ OCons t) = unOCons t
-unOCons t = t
-
-mergecondition :: RType c tv r -> RType c tv r -> RType c tv r
-mergecondition (RAllT _ t1 _) (RAllT v t2 r2) = RAllT v (mergecondition t1 t2) r2
-mergecondition (RAllP _ t1) (RAllP p t2) = RAllP p (mergecondition t1 t2)
-mergecondition (RRTy xts r OCons t1) t2 = RRTy xts r OCons (mergecondition t1 t2)
-mergecondition (RFun _ t11 t12 _) (RFun x2 t21 t22 r2) = RFun x2 (mergecondition t11 t21) (mergecondition t12 t22) r2
-mergecondition _ t = t
-
-safeLogIndex :: Error -> [a] -> Int -> CG (Maybe a)
-safeLogIndex err ls n
- | n >= length ls = addWarning err >> return Nothing
- | otherwise = return $ Just $ ls !! n
-
-checkHint :: (NamedThing a, PPrint a, PPrint a1)
- => a -> [a1] -> (a1 -> Bool) -> Maybe [Int] -> CG (Maybe [Int])
-checkHint _ _ _ Nothing
- = return Nothing
-
-checkHint x _ _ (Just ns) | L.sort ns /= ns
- = addWarning (ErrTermin loc [dx] (text "The hints should be increasing")) >> return Nothing
- where
- loc = getSrcSpan x
- dx = F.pprint x
-
-checkHint x ts f (Just ns)
- = (mapM (checkValidHint x ts f) ns) >>= (return . Just . catMaybes)
-
-checkValidHint :: (NamedThing a, PPrint a, PPrint a1)
- => a -> [a1] -> (a1 -> Bool) -> Int -> CG (Maybe Int)
-checkValidHint x ts f n
- | n < 0 || n >= length ts = addWarning err >> return Nothing
- | f (ts L.!! n) = return $ Just n
- | otherwise = addWarning err >> return Nothing
- where
- err = ErrTermin loc [xd] (vcat [ "Invalid Hint" <+> F.pprint (n+1) <+> "for" <+> xd
- , "in"
- , F.pprint ts ])
- loc = getSrcSpan x
- xd = F.pprint x
-
---------------------------------------------------------------------------------
-consCBLet :: CGEnv -> CoreBind -> CG CGEnv
---------------------------------------------------------------------------------
-consCBLet γ cb = do
- oldtcheck <- tcheck <$> get
- isStr <- doTermCheck (getConfig γ) cb
- -- TODO: yuck.
- modify $ \s -> s { tcheck = oldtcheck && isStr }
- γ' <- consCB (oldtcheck && isStr) isStr γ cb
- modify $ \s -> s{tcheck = oldtcheck}
- return γ'
-
---------------------------------------------------------------------------------
--- | Constraint Generation: Corebind -------------------------------------------
---------------------------------------------------------------------------------
-consCBTop :: Config -> TargetInfo -> CGEnv -> CoreBind -> CG CGEnv
---------------------------------------------------------------------------------
-consCBTop cfg info γ cb
- | all (trustVar cfg info) xs
- = foldM addB γ xs
- where
- xs = bindersOf cb
- tt = trueTy . varType
- addB γ x = tt x >>= (\t -> γ += ("derived", F.symbol x, t))
-
-consCBTop _ _ γ cb
- = do oldtcheck <- tcheck <$> get
- -- lazyVars <- specLazy <$> get
- isStr <- doTermCheck (getConfig γ) cb
- modify $ \s -> s { tcheck = oldtcheck && isStr}
- -- remove invariants that came from the cb definition
- let (γ', i) = removeInvariant γ cb --- DIFF
- γ'' <- consCB (oldtcheck && isStr) isStr (γ'{cgVar = topBind cb}) cb
- modify $ \s -> s { tcheck = oldtcheck}
- return $ restoreInvariant γ'' i --- DIFF
- where
- topBind (NonRec v _) = Just v
- topBind (Rec [(v,_)]) = Just v
- topBind _ = Nothing
-
-trustVar :: Config -> TargetInfo -> Var -> Bool
-trustVar cfg info x = not (checkDerived cfg) && derivedVar (giSrc info) x
-
-derivedVar :: TargetSrc -> Var -> Bool
-derivedVar src x = S.member x (giDerVars src)
-
-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 chk = not (structuralTerm cfg) || any (\x -> S.member x termVs) xs
- return $ chk && not skip
- where
- xs = bindersOf bind
-
--- nonStructTerm && not skip
-
--- RJ: AAAAAAARGHHH!!!!!! THIS CODE IS HORRIBLE!!!!!!!!!
-consCBSizedTys :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv
-consCBSizedTys γ xes
- = do xets <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))
- autoenv <- autoSize <$> get
- ts <- mapM (T.mapM refreshArgs) $ (thd3 <$> xets)
- let vs = zipWith collectArgs ts es
- is <- mapM makeDecrIndex (zip3 xs ts vs) >>= checkSameLens
- let xeets = (\vis -> [(vis, x) | x <- zip3 xs is $ map unTemplate ts]) <$> (zip vs is)
- (L.transpose <$> mapM checkIndex (zip4 xs vs ts is)) >>= checkEqTypes
- 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 xets' = zip3 xs es ts
- mapM_ (uncurry $ consBind True) (zip γs xets')
- return γ'
- where
- (xs, es) = unzip xes
- dxs = F.pprint <$> xs
- collectArgs = GM.collectArguments . length . ty_binds . toRTypeRep . unOCons . unTemplate
- checkEqTypes :: [[Maybe SpecType]] -> CG [[SpecType]]
- checkEqTypes x = mapM (checkAll err1 toRSort) (catMaybes <$> x)
- checkSameLens = checkAll err2 length
- err1 = ErrTermin loc dxs $ text "The decreasing parameters should be of same type"
- err2 = ErrTermin loc dxs $ text "All Recursive functions should have the same number of decreasing parameters"
- loc = getSrcSpan (head xs)
-
- checkAll _ _ [] = return []
- checkAll err f (x:xs)
- | all (==(f x)) (f <$> xs) = return (x:xs)
- | otherwise = addWarning err >> return []
-
-consCBWithExprs :: CGEnv -> [(Var, CoreExpr)] -> CG CGEnv
-consCBWithExprs γ xes
- = do xets <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))
- texprs <- termExprs <$> get
- let xtes = catMaybes $ (`lookup` texprs) <$> xs
- let ts = safeFromAsserted err . thd3 <$> xets
- ts' <- mapM refreshArgs ts
- let xts = zip xs (Asserted <$> ts')
- γ' <- foldM extender γ xts
- let γs = makeTermEnvs γ' xtes xes ts ts'
- let xets' = zip3 xs es (Asserted <$> ts')
- mapM_ (uncurry $ consBind True) (zip γs xets')
- return γ'
- where (xs, es) = unzip xes
- lookup k m | Just x <- M.lookup k m = Just (k, x)
- | otherwise = Nothing
- err = "Constant: consCBWithExprs"
-
-makeTermEnvs :: CGEnv -> [(Var, [F.Located F.Expr])] -> [(Var, CoreExpr)]
- -> [SpecType] -> [SpecType]
- -> [CGEnv]
-makeTermEnvs γ xtes xes ts ts' = setTRec γ . zip xs <$> rts
- where
- vs = zipWith collectArgs ts es
- ys = (fst4 . bkArrowDeep) <$> ts
- ys' = (fst4 . bkArrowDeep) <$> ts'
- sus' = zipWith mkSub ys ys'
- sus = zipWith mkSub ys ((F.symbol <$>) <$> vs)
- ess = (\x -> (safeFromJust (err x) $ (x `L.lookup` xtes))) <$> xs
- tes = zipWith (\su es -> F.subst su <$> es) sus ess
- tes' = zipWith (\su es -> F.subst su <$> es) sus' ess
- rss = zipWith makeLexRefa tes' <$> (repeat <$> tes)
- rts = zipWith (addObligation OTerm) ts' <$> rss
- (xs, es) = unzip xes
- mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys']
- collectArgs = GM.collectArguments . length . ty_binds . toRTypeRep
- err x = "Constant: makeTermEnvs: no terminating expression for " ++ GM.showPpr x
-
-addObligation :: Oblig -> SpecType -> RReft -> SpecType
-addObligation o t r = mkArrow αs πs yts xts $ RRTy [] r o t2
- where
- (αs, πs, t1) = bkUniv t
- ((xs',ts',rs'),(xs, ts, rs), t2) = bkArrow t1
- xts = zip3 xs ts rs
- yts = zip3 xs' ts' rs'
-
---------------------------------------------------------------------------------
-consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv
---------------------------------------------------------------------------------
--- do termination checking
-consCB True _ γ (Rec xes)
- = do texprs <- termExprs <$> get
- modify $ \i -> i { recCount = recCount i + length xes }
- let xxes = catMaybes $ (`lookup` texprs) <$> xs
- if null xxes
- then consCBSizedTys γ xes
- else check xxes <$> consCBWithExprs γ xes
- where
- xs = fst (unzip xes)
- check ys r | length ys == length xs = r
- | otherwise = panic (Just loc) $ msg
- msg = "Termination expressions must be provided for all mutually recursive binders"
- loc = getSrcSpan (head xs)
- lookup k m = (k,) <$> M.lookup k m
-
--- don't do termination checking, but some strata checks?
-consCB _ False γ (Rec xes)
- = do xets <- forM xes $ \(x, e) -> (x, e,) <$> varTemplate γ (x, Just e)
- modify $ \i -> i { recCount = recCount i + length xes }
- let xts = [(x, to) | (x, _, to) <- xets]
- γ' <- foldM extender (γ `setRecs` (fst <$> xts)) xts
- mapM_ (consBind True γ') xets
- return γ'
-
--- don't do termination checking, and don't do any strata checks either?
-consCB _ _ γ (Rec xes)
- = do xets <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e))
- modify $ \i -> i { recCount = recCount i + length xes }
- let xts = [(x, to) | (x, _, to) <- xets]
- γ' <- foldM extender (γ `setRecs` (fst <$> xts)) xts
- mapM_ (consBind True γ') xets
- return γ'
-
--- | NV: Dictionaries are not checked, because
--- | class methods' preconditions are not satisfied
-consCB _ _ γ (NonRec x _) | isDictionary x
- = do t <- trueTy (varType x)
- extender γ (x, Assumed t)
- where
- isDictionary = isJust . dlookup (denv γ)
-
-
-consCB _ _ γ (NonRec x _ ) | isHoleVar x && typedHoles (getConfig γ)
- = return γ
-
-consCB _ _ γ (NonRec x def)
- | Just (w, τ) <- grepDictionary def
- , Just d <- dlookup (denv γ) w
- = do t <- mapM trueTy τ
- mapM addW (WfC γ <$> t)
- let xts = dmap (fmap (f t)) d
- let γ' = γ { denv = dinsert (denv γ) x xts }
- t <- trueTy (varType x)
- extender γ' (x, Assumed t)
- where
- f [t'] (RAllT α te _) = subsTyVar_meet' (ty_var_value α, t') te
- f (t':ts) (RAllT α te _) = f ts $ subsTyVar_meet' (ty_var_value α, t') te
- f _ _ = impossible Nothing "consCB on Dictionary: this should not happen"
-
-consCB _ _ γ (NonRec x e)
- = do to <- varTemplate γ (x, Nothing)
- to' <- consBind False γ (x, e, to) >>= (addPostTemplate γ)
- extender γ (x, makeSingleton γ (simplify e) <$> to')
-
-grepDictionary :: CoreExpr -> Maybe (Var, [Type])
-grepDictionary = go []
- where
- go ts (App (Var w) (Type t)) = Just (w, reverse (t:ts))
- go ts (App e (Type t)) = go (t:ts) e
- go ts (App e (Var _)) = go ts e
- go _ _ = Nothing
-
---------------------------------------------------------------------------------
-consBind :: Bool -> CGEnv -> (Var, CoreExpr, Template SpecType) -> CG (Template SpecType)
---------------------------------------------------------------------------------
-consBind _ _ (x, _, Assumed t)
- | RecSelId {} <- idDetails x -- don't check record selectors with assumed specs
- = return $ F.notracepp ("TYPE FOR SELECTOR " ++ show x) $ Assumed t
-
-consBind isRec γ (x, e, Asserted spect)
- = do let γ' = γ `setBind` x
- (_,πs,_) = bkUniv spect
- γπ <- foldM addPToEnv γ' πs
-
- -- take implcits out of the function's SpecType and into the env
- let tyr = toRTypeRep spect
- let spect' = fromRTypeRep (tyr { ty_ebinds = [], ty_eargs = [], ty_erefts = [] })
- γπ <- foldM (+=) γπ $ (\(y,t)->("implicitError",y,t)) <$> zip (ty_ebinds tyr) (ty_eargs tyr)
-
- cconsE γπ e (weakenResult x spect')
- when (F.symbol x `elemHEnv` holes γ) $
- -- have to add the wf constraint here for HOLEs so we have the proper env
- addW $ WfC γπ $ fmap killSubst spect
- addIdA x (defAnn isRec spect)
- return $ Asserted spect
-
-consBind isRec γ (x, e, Internal spect)
- = do let γ' = γ `setBind` x
- (_,πs,_) = bkUniv spect
- γπ <- foldM addPToEnv γ' πs
- let γπ' = γπ {cerr = Just $ ErrHMeas (getLocation γπ) (pprint x) (text explanation)}
- cconsE γπ' e spect
- when (F.symbol x `elemHEnv` holes γ) $
- -- have to add the wf constraint here for HOLEs so we have the proper env
- addW $ WfC γπ $ fmap killSubst spect
- addIdA x (defAnn isRec spect)
- return $ Internal spect
- where
- explanation = "Cannot give singleton type to the function definition."
-
-consBind isRec γ (x, e, Assumed spect)
- = do let γ' = γ `setBind` x
- γπ <- foldM addPToEnv γ' πs
- cconsE γπ e =<< true spect
- addIdA x (defAnn isRec spect)
- return $ Asserted spect
- where πs = ty_preds $ toRTypeRep spect
-
-consBind isRec γ (x, e, Unknown)
- = do t' <- consE (γ `setBind` x) e
- t <- topSpecType x t'
- addIdA x (defAnn isRec t)
- when (isExportedId x) (addKuts x t)
- return $ Asserted t
-
-killSubst :: RReft -> RReft
-killSubst = fmap killSubstReft
-
-killSubstReft :: F.Reft -> F.Reft
-killSubstReft = trans kv () ()
- where
- kv = defaultVisitor { txExpr = ks }
- ks _ (F.PKVar k _) = F.PKVar k mempty
- ks _ p = p
-
-defAnn :: Bool -> t -> Annot t
-defAnn True = AnnRDf
-defAnn False = AnnDef
-
-addPToEnv :: CGEnv
- -> PVar RSort -> CG CGEnv
-addPToEnv γ π
- = do γπ <- γ += ("addSpec1", pname π, pvarRType π)
- foldM (+=) γπ [("addSpec2", x, ofRSort t) | (t, x, _) <- pargs π]
-
-extender :: F.Symbolic a => CGEnv -> (a, Template SpecType) -> CG CGEnv
-extender γ (x, Asserted t)
- = case lookupREnv (F.symbol x) (assms γ) of
- Just t' -> γ += ("extender", F.symbol x, t')
- _ -> γ += ("extender", F.symbol x, t)
-extender γ (x, Assumed t)
- = γ += ("extender", F.symbol x, t)
-extender γ _
- = return γ
-
-data Template a
- = Asserted a
- | Assumed a
- | Internal a
- | Unknown
- deriving (Functor, F.Foldable, T.Traversable)
-
-deriving instance (Show a) => (Show (Template a))
-
-instance PPrint a => PPrint (Template a) where
- pprintTidy k (Asserted t) = "Asserted" <+> pprintTidy k t
- pprintTidy k (Assumed t) = "Assumed" <+> pprintTidy k t
- pprintTidy k (Internal t) = "Internal" <+> pprintTidy k t
- pprintTidy _ Unknown = "Unknown"
-
-unTemplate :: Template t -> t
-unTemplate (Asserted t) = t
-unTemplate (Assumed t) = t
-unTemplate (Internal t) = t
-unTemplate _ = panic Nothing "Constraint.Generate.unTemplate called on `Unknown`"
-
-addPostTemplate :: CGEnv
- -> Template SpecType
- -> CG (Template SpecType)
-addPostTemplate γ (Asserted t) = Asserted <$> addPost γ t
-addPostTemplate γ (Assumed t) = Assumed <$> addPost γ t
-addPostTemplate γ (Internal t) = Internal <$> addPost γ t
-addPostTemplate _ Unknown = return Unknown
-
-safeFromAsserted :: [Char] -> Template t -> t
-safeFromAsserted _ (Asserted t) = t
-safeFromAsserted msg _ = panic Nothing $ "safeFromAsserted:" ++ msg
-
--- | @varTemplate@ is only called with a `Just e` argument when the `e`
--- corresponds to the body of a @Rec@ binder.
-varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)
-varTemplate γ (x, eo) = varTemplate' γ (x, eo) >>= mapM (topSpecType x)
-
--- | @lazVarTemplate@ is like `varTemplate` but for binders that are *not*
--- termination checked and hence, the top-level refinement / KVar is
--- stripped out. e.g. see tests/neg/T743.hs
--- varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)
--- lazyVarTemplate γ (x, eo) = dbg <$> (topRTypeBase <$>) <$> varTemplate' γ (x, eo)
--- where
--- dbg = traceShow ("LAZYVAR-TEMPLATE: " ++ show x)
-
-varTemplate' :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType)
-varTemplate' γ (x, eo)
- = case (eo, lookupREnv (F.symbol x) (grtys γ), lookupREnv (F.symbol x) (assms γ), lookupREnv (F.symbol x) (intys γ)) of
- (_, Just t, _, _) -> Asserted <$> refreshArgsTop (x, t)
- (_, _, _, Just t) -> Internal <$> refreshArgsTop (x, t)
- (_, _, Just t, _) -> Assumed <$> refreshArgsTop (x, t)
- (Just e, _, _, _) -> do t <- freshTy_expr (RecBindE x) e (exprType e)
- addW (WfC γ t)
- Asserted <$> refreshArgsTop (x, t)
- (_, _, _, _) -> return Unknown
-
--- | @topSpecType@ strips out the top-level refinement of "derived var"
-topSpecType :: Var -> SpecType -> CG SpecType
-topSpecType x t = do
- info <- ghcI <$> get
- return $ if derivedVar (giSrc info) x then topRTypeBase t else t
-
---------------------------------------------------------------------------------
--- | Bidirectional Constraint Generation: CHECKING -----------------------------
---------------------------------------------------------------------------------
-cconsE :: CGEnv -> CoreExpr -> SpecType -> CG ()
---------------------------------------------------------------------------------
-cconsE g e t = do
- -- NOTE: tracing goes here
- -- traceM $ printf "cconsE:\n expr = %s\n exprType = %s\n lqType = %s\n" (showPpr e) (showPpr (exprType e)) (showpp t)
- cconsE' g e t
-
---------------------------------------------------------------------------------
-cconsE' :: CGEnv -> CoreExpr -> SpecType -> CG ()
---------------------------------------------------------------------------------
-cconsE' γ e t
- | Just (Rs.PatSelfBind _x e') <- Rs.lift e
- = cconsE' γ e' t
-
- | Just (Rs.PatSelfRecBind x e') <- Rs.lift e
- = let γ' = γ { grtys = insertREnv (F.symbol x) t (grtys γ)}
- in void $ consCBLet γ' (Rec [(x, e')])
-
-cconsE' γ e@(Let b@(NonRec x _) ee) t
- = do sp <- specLVars <$> get
- if (x `S.member` sp)
- then cconsLazyLet γ e t
- else do γ' <- consCBLet γ b
- cconsE γ' ee t
-
-cconsE' γ e (RAllP p t)
- = cconsE γ' e t''
- where
- t' = replacePredsWithRefs su <$> t
- su = (uPVar p, pVartoRConc p)
- (css, t'') = splitConstraints t'
- γ' = L.foldl' addConstraints γ css
-
-cconsE' γ (Let b e) t
- = do γ' <- consCBLet γ b
- cconsE γ' e t
-
-cconsE' γ (Case e x _ cases) t
- = do γ' <- consCBLet γ (NonRec x e)
- forM_ cases $ cconsCase γ' x t nonDefAlts
- where
- nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT]
- _msg = "cconsE' #nonDefAlts = " ++ show (length (nonDefAlts))
-
-cconsE' γ (Lam α e) (RAllT α' t r) | isTyVar α
- = do γ' <- updateEnvironment γ α
- addForAllConstraint γ' α e (RAllT α' t r)
- cconsE γ' e $ subsTyVar_meet' (ty_var_value α', rVar α) t
-
-cconsE' γ (Lam x e) (RFun y ty t r)
- | not (isTyVar x)
- = do γ' <- γ += ("cconsE", x', ty)
- cconsE γ' e t'
- addFunctionConstraint γ x e (RFun x' ty t' r')
- addIdA x (AnnDef ty)
- where
- x' = F.symbol x
- t' = t `F.subst1` (y, F.EVar x')
- r' = r `F.subst1` (y, F.EVar x')
-
-cconsE' γ (Tick tt e) t
- = cconsE (γ `setLocation` (Sp.Tick tt)) e t
-
-cconsE' γ (Cast e co) t
- -- See Note [Type classes with a single method]
- | Just f <- isClassConCo co
- = cconsE γ (f e) t
-
-cconsE' γ e@(Cast e' c) t
- = do t' <- castTy γ (exprType e) e' c
- addC (SubC γ (F.notracepp ("Casted Type for " ++ GM.showPpr e ++ "\n init type " ++ showpp t) t') t) ("cconsE Cast: " ++ GM.showPpr e)
-
-cconsE' γ (Var x) t | isHoleVar x && typedHoles (getConfig γ)
- = addHole x t γ
-
-cconsE' γ e t
- = 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)
-
-lambdaSingleton :: CGEnv -> F.TCEmb TyCon -> Var -> CoreExpr -> UReft F.Reft
-lambdaSingleton γ tce x e
- | higherOrderFlag γ, Just e' <- lamExpr γ e
- = uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'
- where
- sx = typeSort tce $ Ghc.expandTypeSynonyms $ varType x
-lambdaSingleton _ _ _ _
- = mempty
-
-addForAllConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG ()
-addForAllConstraint γ _ _ (RAllT a t r)
- | F.isTauto r
- = return ()
- | otherwise
- = do t' <- true t
- let truet = RAllT a $ unRAllP t'
- addC (SubC γ (truet mempty) $ truet r) "forall constraint true"
- where unRAllP (RAllT a t r) = RAllT a (unRAllP t) r
- unRAllP (RAllP _ t) = unRAllP t
- unRAllP t = t
-addForAllConstraint γ _ _ _
- = impossible (Just $ getLocation γ) "addFunctionConstraint: called on non function argument"
-
-
-addFunctionConstraint :: CGEnv -> Var -> CoreExpr -> SpecType -> CG ()
-addFunctionConstraint γ x e (RFun y ty t r)
- = do ty' <- true ty
- t' <- true t
- let truet = RFun y ty' t'
- case (lamExpr γ e, higherOrderFlag γ) of
- (Just e', True) -> do tce <- tyConEmbed <$> get
- let sx = typeSort tce $ varType x
- let ref = uTop $ F.exprReft $ F.ELam (F.symbol x, sx) e'
- addC (SubC γ (truet ref) $ truet r) "function constraint singleton"
- _ -> addC (SubC γ (truet mempty) $ truet r) "function constraint true"
-addFunctionConstraint γ _ _ _
- = impossible (Just $ getLocation γ) "addFunctionConstraint: called on non function argument"
-
-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
- = let (css, t') = splitConstraints t in (css, RFun x tx t' r)
-splitConstraints t
- = ([], t)
-
--------------------------------------------------------------------
--- | @instantiateGhosts@ peels away implicit argument binders,
--- instantiates them with fresh variables, and adds those variables
--- to the context as @ebind@s TODO: the second half
--------------------------------------------------------------------
-instantiateGhosts :: CGEnv
- -> SpecType
- -> CG (Bool, CGEnv, SpecType)
-instantiateGhosts γ t | not (null yts)
- = do ys' <- mapM (const fresh) ys
- γ' <- foldM addEEnv γ (zip ys' ts)
-
- let su = F.mkSubst $ zip ys (F.EVar <$> ys')
- return (True, γ', F.subst su te')
- where (yts, te') = bkImplicit t
- (ys, ts) = unzip yts
-
-instantiateGhosts γ t = return (False, γ, t)
-
-bkImplicit :: RType c tv r
- -> ( [(F.Symbol, RType c tv r)]
- , RType c tv r)
-bkImplicit (RImpF x tx t _) = ((x,tx):acc, t')
- where (acc,t') = bkImplicit t
-bkImplicit t = ([],t)
-
--------------------------------------------------------------------
--- | @instantiatePreds@ peels away the universally quantified @PVars@
--- of a @RType@, generates fresh @Ref@ for them and substitutes them
--- in the body.
--------------------------------------------------------------------
-instantiatePreds :: CGEnv
- -> CoreExpr
- -> SpecType
- -> CG SpecType
-instantiatePreds γ e (RAllP π t)
- = do r <- freshPredRef γ e π
- instantiatePreds γ e $ replacePreds "consE" t [(π, r)]
-
-instantiatePreds _ _ t0
- = return t0
-
-
--------------------------------------------------------------------
-cconsLazyLet :: CGEnv
- -> CoreExpr
- -> SpecType
- -> CG ()
-cconsLazyLet γ (Let (NonRec x ex) e) t
- = do tx <- trueTy (varType x)
- γ' <- (γ, "Let NonRec") +++= (x', ex, tx)
- cconsE γ' e t
- where
- x' = F.symbol x
-
-cconsLazyLet _ _ _
- = panic Nothing "Constraint.Generate.cconsLazyLet called on invalid inputs"
-
---------------------------------------------------------------------------------
--- | Bidirectional Constraint Generation: SYNTHESIS ----------------------------
---------------------------------------------------------------------------------
-consE :: CGEnv -> CoreExpr -> CG SpecType
---------------------------------------------------------------------------------
-consE γ e
- | patternFlag γ
- , Just p <- Rs.lift e
- = consPattern γ (F.notracepp "CONSE-PATTERN: " p) (exprType e)
-
--- NV CHECK 3 (unVar and does this hack even needed?)
--- NV (below) is a hack to type polymorphic axiomatized functions
--- no need to check this code with flag, the axioms environment with
--- is empty if there is no axiomatization.
-
--- [NOTE: PLE-OPT] We *disable* refined instantiation for
--- reflected functions inside proofs.
-consE γ (Var x)
- = do t <- varRefType γ x
- addLocA (Just x) (getLocation γ) (varAnn γ x t)
- return t
-
-consE _ (Lit c)
- = refreshVV $ uRType $ literalFRefType c
-
-consE γ e'@(App e a@(Type τ))
- = do RAllT α te _ <- checkAll ("Non-all TyApp with expr", e) γ <$> consE γ e
- t <- if not (nopolyinfer (getConfig γ)) && isPos α && isGenericVar (ty_var_value α) te
- then freshTy_type TypeInstE e τ
- else trueTy τ
- addW $ WfC γ t
- t' <- refreshVV t
- tt0 <- instantiatePreds γ e' (subsTyVar_meet' (ty_var_value α, t') te)
- let tt = makeSingleton γ (simplify e') $ subsTyReft γ (ty_var_value α) τ tt0
- case rTVarToBind α of
- Just (x, _) -> return $ maybe (checkUnbound γ e' x tt a) (F.subst1 tt . (x,)) (argType τ)
- Nothing -> return tt
- where
- isPos α = not (extensionality (getConfig γ)) || rtv_is_pol (ty_var_info α)
-
-consE γ e'@(App e a) | Just aDict <- getExprDict γ a
- = case dhasinfo (dlookup (denv γ) aDict) (getExprFun γ e) of
- Just riSig -> return $ fromRISig riSig
- _ -> do
- ([], πs, te) <- bkUniv <$> consE γ e
- te' <- instantiatePreds γ e' $ foldr RAllP te πs
- (γ', te''') <- dropExists γ te'
- te'' <- dropConstraints γ te'''
- updateLocA {- πs -} (exprLoc e) te''
- let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') γ te''
- cconsE γ' a tx
- addPost γ' $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a)
-
-consE γ e'@(App e a)
- = do ([], πs, te) <- bkUniv <$> consE γ ({- GM.tracePpr ("APP-EXPR: " ++ GM.showPpr (exprType e)) -} e)
- te' <- instantiatePreds γ e' $ foldr RAllP te πs
- (γ', te''') <- dropExists γ te'
- te'' <- dropConstraints γ te'''
- updateLocA (exprLoc e) te''
- (hasGhost, γ'', te''') <- instantiateGhosts γ' te''
- let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') γ te'''
- cconsE γ'' a tx
- tout <- makeSingleton γ'' (simplify e') <$> (addPost γ'' $ maybe (checkUnbound γ'' e' x t a) (F.subst1 t . (x,)) (argExpr γ $ simplify a))
- if hasGhost
- then do
- tk <- freshTy_type ImplictE e' $ exprType e'
- addW $ WfC γ tk
- addC (SubC γ'' tout tk) ""
- return tk
- else return tout
-
-consE γ (Lam α e) | isTyVar α
- = do γ' <- updateEnvironment γ α
- t' <- consE γ' e
- return $ RAllT (makeRTVar $ rTyVar α) t' mempty
-
-consE γ e@(Lam x e1)
- = do tx <- freshTy_type LamE (Var x) τx
- γ' <- γ += ("consE", F.symbol x, tx)
- t1 <- consE γ' e1
- addIdA x $ AnnDef tx
- addW $ WfC γ tx
- tce <- tyConEmbed <$> get
- return $ RFun (F.symbol x) tx t1 $ lambdaSingleton γ tce x e1
- where
- FunTy { ft_arg = τx } = exprType e
-
-consE γ e@(Let _ _)
- = cconsFreshE LetE γ e
-
-consE γ e@(Case _ _ _ [_])
- | Just p@(Rs.PatProject {}) <- Rs.lift e
- = consPattern γ p (exprType e)
-
-consE γ e@(Case _ _ _ cs)
- = cconsFreshE (caseKVKind cs) γ e
-
-consE γ (Tick tt e)
- = do t <- consE (setLocation γ (Sp.Tick tt)) e
- addLocA Nothing (GM.tickSrcSpan tt) (AnnUse t)
- return t
-
--- See Note [Type classes with a single method]
-consE γ (Cast e co)
- | Just f <- isClassConCo co
- = consE γ (f e)
-
-consE γ e@(Cast e' c)
- = castTy γ (exprType e) e' c
-
-consE _ e@(Coercion _)
- = trueTy $ exprType e
-
-consE _ e@(Type t)
- = panic Nothing $ "consE cannot handle type " ++ GM.showPpr (e, t)
-
-caseKVKind ::[Alt Var] -> KVKind
-caseKVKind [(DataAlt _, _, Var _)] = ProjectE
-caseKVKind cs = CaseE (length cs)
-
-updateEnvironment :: CGEnv -> TyVar -> CG CGEnv
-updateEnvironment γ a
- | isValKind (tyVarKind a)
- = γ += ("varType", F.symbol $ varName a, kindToRType $ tyVarKind a)
- | otherwise
- = return γ
-
-getExprFun :: CGEnv -> CoreExpr -> Var
-getExprFun γ e = go e
- where
- go (App x (Type _)) = go x
- go (Var x) = x
- go _ = panic (Just (getLocation γ)) msg
- msg = "getFunName on \t" ++ GM.showPpr e
-
--- | `exprDict e` returns the dictionary `Var` inside the expression `e`
-getExprDict :: CGEnv -> CoreExpr -> Maybe Var
-getExprDict γ = go
- where
- go (Var x) = case dlookup (denv γ) x of {Just _ -> Just x; Nothing -> Nothing}
- go (Tick _ e) = go e
- go (App a (Type _)) = go a
- go _ = Nothing
-
---------------------------------------------------------------------------------
--- | With GADTs and reflection, refinements can contain type variables,
--- as 'coercions' (see ucsd-progsys/#1424). At application sites, we
--- must also substitute those from the refinements (not just the types).
--- https://github.com/ucsd-progsys/liquidhaskell/issues/1424
---
--- see: tests/ple/{pos,neg}/T1424.hs
---
---------------------------------------------------------------------------------
-
-subsTyReft :: CGEnv -> RTyVar -> Type -> SpecType -> SpecType
-subsTyReft γ a t = mapExprReft (\_ -> F.applyCoSub coSub)
- where
- coSub = M.fromList [(F.symbol a, typeSort (emb γ) t)]
-
---------------------------------------------------------------------------------
--- | Type Synthesis for Special @Pattern@s -------------------------------------
---------------------------------------------------------------------------------
-consPattern :: CGEnv -> Rs.Pattern -> Type -> CG SpecType
-
-{- [NOTE] special type rule for monadic-bind application
-
- G |- e1 ~> m tx G, x:tx |- e2 ~> m t
- -----------------------------------------
- G |- (e1 >>= \x -> e2) ~> m t
- -}
-
-consPattern γ (Rs.PatBind e1 x e2 _ _ _ _ _) _ = do
- tx <- checkMonad (msg, e1) γ <$> consE γ e1
- γ' <- γ += ("consPattern", F.symbol x, tx)
- addIdA x (AnnDef tx)
- mt <- consE γ' e2
- return mt
- where
- msg = "This expression has a refined monadic type; run with --no-pattern-inline: "
-
-{- [NOTE] special type rule for monadic-return
-
- G |- e ~> et
- ------------------------
- G |- return e ~ m et
- -}
-consPattern γ (Rs.PatReturn e m _ _ _) t = do
- et <- F.notracepp "Cons-Pattern-Ret" <$> consE γ e
- mt <- trueTy m
- tt <- trueTy t
- return (mkRAppTy mt et tt) -- /// {- $ RAppTy mt et mempty -}
-
-{- [NOTE] special type rule for field projection, is
- t = G(x) ti = Proj(t, i)
- -----------------------------------------
- G |- case x of C [y1...yn] -> yi : ti
- -}
-
-consPattern γ (Rs.PatProject xe _ τ c ys i) _ = do
- let yi = ys !! i
- t <- (addW . WfC γ) <<= freshTy_type ProjectE (Var yi) τ
- γ' <- caseEnv γ xe [] (DataAlt c) ys (Just [i])
- ti <- {- γ' ??= yi -} varRefType γ' yi
- addC (SubC γ' ti t) "consPattern:project"
- return t
-
-consPattern γ (Rs.PatSelfBind _ e) _ =
- consE γ e
-
-consPattern γ p@(Rs.PatSelfRecBind {}) _ =
- cconsFreshE LetE γ (Rs.lower p)
-
-mkRAppTy :: SpecType -> SpecType -> SpecType -> SpecType
-mkRAppTy mt et (RAppTy _ _ _) = RAppTy mt et mempty
-mkRAppTy _ et (RApp c [_] [] _) = RApp c [et] [] mempty
-mkRAppTy _ _ _ = panic Nothing $ "Unexpected return-pattern"
-
-checkMonad :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType
-checkMonad x g = go . unRRTy
- where
- go (RApp _ ts [] _)
- | length ts > 0 = last ts
- go (RAppTy _ t _) = t
- go t = checkErr x g t
-
-unRRTy :: SpecType -> SpecType
-unRRTy (RRTy _ _ _ t) = unRRTy t
-unRRTy t = t
-
---------------------------------------------------------------------------------
-castTy :: CGEnv -> Type -> CoreExpr -> Coercion -> CG SpecType
-castTy' :: CGEnv -> Type -> CoreExpr -> CG SpecType
---------------------------------------------------------------------------------
-castTy γ t e (AxiomInstCo ca _ _)
- = fromMaybe <$> castTy' γ t e <*> lookupNewType (coAxiomTyCon ca)
-
-castTy γ t e (SymCo (AxiomInstCo ca _ _))
- = do mtc <- lookupNewType (coAxiomTyCon ca)
- case mtc of
- Just tc -> cconsE γ e tc
- Nothing -> return ()
- castTy' γ t e
-
-castTy γ t e _
- = castTy' γ t e
-
-
-castTy' γ τ (Var x)
- = do t <- trueTy τ
- -- tx <- varRefType γ x -- NV HERE: the refinements of the var x do not get into the
- -- -- environment. Check
- let ce = eCoerc (typeSort (emb γ) $ Ghc.expandTypeSynonyms $ varType x)
- (typeSort (emb γ) τ)
- $ F.expr x
- return ((t `strengthen` (uTop $ F.uexprReft $ ce)) {- `F.meet` tx -})
- where eCoerc s t e
- | s == t = e
- | otherwise = F.ECoerc s t e
-
-castTy' γ t (Tick _ e)
- = castTy' γ t e
-
-castTy' _ _ e
- = panic Nothing $ "castTy cannot handle expr " ++ GM.showPpr e
-
-{-
-showCoercion :: Coercion -> String
-showCoercion (AxiomInstCo co1 co2 co3)
- = "AxiomInstCo " ++ showPpr co1 ++ "\t\t " ++ showPpr co2 ++ "\t\t" ++ showPpr co3 ++ "\n\n" ++
- "COAxiom Tycon = " ++ showPpr (coAxiomTyCon co1) ++ "\nBRANCHES\n" ++ concatMap showBranch bs
- where
- bs = fromBranchList $ co_ax_branches co1
- showBranch ab = "\nCoAxiom \nLHS = " ++ showPpr (coAxBranchLHS ab) ++
- "\nRHS = " ++ showPpr (coAxBranchRHS ab)
-showCoercion (SymCo c)
- = "Symc :: " ++ showCoercion c
-showCoercion c
- = "Coercion " ++ showPpr c
--}
-
-isClassConCo :: Coercion -> Maybe (Expr Var -> Expr Var)
--- See Note [Type classes with a single method]
-isClassConCo co
- | Pair t1 t2 <- coercionKind co
- , isClassPred t2
- , (tc,ts) <- splitTyConApp t2
- , [dc] <- tyConDataCons tc
- , [tm] <- dataConOrigArgTys dc
- -- tcMatchTy because we have to instantiate the class tyvars
- , Just _ <- ruleMatchTyX (mkUniqSet $ tyConTyVars tc) (mkRnEnv2 emptyInScopeSet) emptyTvSubstEnv tm t1
- = Just (\e -> mkCoreConApps dc $ map Type ts ++ [e])
-
- | otherwise
- = Nothing
- where
- ruleMatchTyX =ruleMatchTyKiX -- TODO: is this correct?
-
-----------------------------------------------------------------------
--- Note [Type classes with a single method]
-----------------------------------------------------------------------
--- GHC 7.10 encodes type classes with a single method as newtypes and
--- `cast`s between the method and class type instead of applying the
--- class constructor. Just rewrite the core to what we're used to
--- seeing..
---
--- specifically, we want to rewrite
---
--- e `cast` ((a -> b) ~ C)
---
--- to
---
--- D:C e
---
--- but only when
---
--- D:C :: (a -> b) -> C
-
---------------------------------------------------------------------------------
--- | @consFreshE@ is used to *synthesize* types with a **fresh template**.
--- e.g. at joins, recursive binders, polymorphic instantiations etc. It is
--- the "portal" that connects `consE` (synthesis) and `cconsE` (checking)
---------------------------------------------------------------------------------
-cconsFreshE :: KVKind -> CGEnv -> CoreExpr -> CG SpecType
-cconsFreshE kvkind γ e = do
- t <- freshTy_type kvkind e $ exprType e
- addW $ WfC γ t
- cconsE γ e t
- return t
---------------------------------------------------------------------------------
-
-checkUnbound :: (Show a, Show a2, F.Subable a)
- => CGEnv -> CoreExpr -> F.Symbol -> a -> a2 -> a
-checkUnbound γ e x t a
- | x `notElem` (F.syms t) = t
- | otherwise = panic (Just $ getLocation γ) msg
- where
- msg = unlines [ "checkUnbound: " ++ show x ++ " is elem of syms of " ++ show t
- , "In", GM.showPpr e, "Arg = " , show a ]
-
-
-dropExists :: CGEnv -> SpecType -> CG (CGEnv, SpecType)
-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
- = (flip (RFun x tx)) r <$> dropConstraints γ t
-dropConstraints γ (RRTy cts _ OCons t)
- = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts
- addC (SubC γ' t1 t2) "dropConstraints"
- dropConstraints γ t
- where
- (xts, t1, t2) = envToSub cts
-
-dropConstraints _ t = return t
-
--------------------------------------------------------------------------------------
-cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> (AltCon, [Var], CoreExpr) -> CG ()
--------------------------------------------------------------------------------------
-cconsCase γ x t acs (ac, ys, ce)
- = do cγ <- caseEnv γ x acs ac ys mempty
- cconsE cγ ce t
-
-{-
-
-case x :: List b of
- Emp -> e
-
- Emp :: tdc forall a. {v: List a | cons v === 0}
- x :: xt List b
- ys == binders []
-
--}
--------------------------------------------------------------------------------------
-caseEnv :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> Maybe [Int] -> CG CGEnv
--------------------------------------------------------------------------------------
-caseEnv γ x _ (DataAlt c) ys pIs = do
-
- let (x' : ys') = F.symbol <$> (x:ys)
- xt0 <- checkTyCon ("checkTycon cconsCase", x) γ <$> γ ??= x
- let xt = shiftVV xt0 x'
- tdc <- (γ ??= (dataConWorkId c) >>= refreshVV)
- let (rtd,yts',_) = unfoldR tdc xt ys
- yts <- projectTypes pIs yts'
- let ys'' = F.symbol <$> filter (not . GM.isEvVar) ys
- let r1 = dataConReft c ys''
- let r2 = dataConMsReft rtd ys''
- let xt = (xt0 `F.meet` rtd) `strengthen` (uTop (r1 `F.meet` r2))
- let cbs = safeZip "cconsCase" (x':ys') (xt0 : yts)
- cγ' <- addBinders γ x' cbs
- addBinders cγ' x' [(x', xt)]
-
-caseEnv γ x acs a _ _ = do
- let x' = F.symbol x
- xt' <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x)
- cγ <- addBinders γ x' [(x', xt')]
- return cγ
-
---------------------------------------------------------------------------------
--- | `projectTypes` masks (i.e. true's out) all types EXCEPT those
--- at given indices; it is used to simplify the environment used
--- when projecting out fields of single-ctor datatypes.
---------------------------------------------------------------------------------
-projectTypes :: Maybe [Int] -> [SpecType] -> CG [SpecType]
-projectTypes Nothing ts = return ts
-projectTypes (Just is) ts = mapM (projT is) (zip [0..] ts)
- where
- projT is (j, t)
- | j `elem` is = return t
- | otherwise = true t
-
-altReft :: CGEnv -> [AltCon] -> AltCon -> F.Reft
-altReft _ _ (LitAlt l) = literalFReft l
-altReft γ acs DEFAULT = mconcat ([notLiteralReft l | LitAlt l <- acs] ++ [notDataConReft d | DataAlt d <- acs])
- where
- notLiteralReft = maybe mempty F.notExprReft . snd . literalConst (emb γ)
- notDataConReft d | exactDC (getConfig γ)
- = F.Reft (F.vv_, F.PNot (F.EApp (F.EVar $ makeDataConChecker d) (F.EVar F.vv_)))
- | otherwise = mempty
-altReft _ _ _ = panic Nothing "Constraint : altReft"
-
-unfoldR :: SpecType -> SpecType -> [Var] -> (SpecType, [SpecType], SpecType)
-unfoldR td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt)
- where
- tbody = instantiatePvs (instantiateTys td ts) (reverse rs)
- -- TODO: if we ever want to support applying implicits explicitly, will need to rejigger
- ((_,_,_),(ys0,yts',_), rt) = safeBkArrow (F.notracepp msg $ instantiateTys tbody tvs')
- msg = "INST-TY: " ++ F.showpp (td, ts, tbody, ys, tvs')
- yts'' = zipWith F.subst sus (yts'++[rt])
- (t3,yts) = (last yts'', init yts'')
- sus = F.mkSubst <$> (L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys'])
- (αs, ys') = mapSnd (F.symbol <$>) $ L.partition isTyVar ys
- tvs' :: [SpecType]
- tvs' = rVar <$> αs
- tvys = ofType . varType <$> αs
-
-unfoldR _ _ _ = panic Nothing "Constraint.hs : unfoldR"
-
-instantiateTys :: SpecType -> [SpecType] -> SpecType
-instantiateTys = L.foldl' go
- where
- go (RAllT α tbody _) t = subsTyVar_meet' (ty_var_value α, t) tbody
- go _ _ = panic Nothing "Constraint.instantiateTy"
-
-instantiatePvs :: SpecType -> [SpecProp] -> SpecType
-instantiatePvs = L.foldl' go
- where
- go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)]
- go t _ = errorP "" ("Constraint.instantiatePvs: t = " ++ showpp t)
-
-checkTyCon :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType
-checkTyCon _ _ t@(RApp _ _ _ _) = t
-checkTyCon x g t = checkErr x g t
-
-checkFun :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType
-checkFun _ _ t@(RFun _ _ _ _) = t
-checkFun x g t = checkErr x g t
-
-checkAll :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType
-checkAll _ _ t@(RAllT _ _ _) = t
-checkAll x g t = checkErr x g t
-
-checkErr :: (Outputable a) => (String, a) -> CGEnv -> SpecType -> SpecType
-checkErr (msg, e) γ t = panic (Just sp) $ msg ++ GM.showPpr e ++ ", type: " ++ showpp t
- where
- sp = getLocation γ
-
-varAnn :: CGEnv -> Var -> t -> Annot t
-varAnn γ x t
- | x `S.member` recs γ = AnnLoc (getSrcSpan x)
- | otherwise = AnnUse t
-
------------------------------------------------------------------------
--- | Helpers: Creating Fresh Refinement -------------------------------
------------------------------------------------------------------------
-freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp
-freshPredRef γ e (PV _ (PVProp τ) _ as)
- = do t <- freshTy_type PredInstE e (toType τ)
- args <- mapM (\_ -> fresh) as
- let targs = [(x, s) | (x, (s, y, z)) <- zip args as, (F.EVar y) == z ]
- γ' <- foldM (+=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs]
- addW $ WfC γ' t
- return $ RProp targs t
-
-freshPredRef _ _ (PV _ PVHProp _ _)
- = todo Nothing "EFFECTS:freshPredRef"
-
-
---------------------------------------------------------------------------------
--- | Helpers: Creating Refinement Types For Various Things ---------------------
---------------------------------------------------------------------------------
-argType :: Type -> Maybe F.Expr
-argType (LitTy (NumTyLit i))
- = mkI i
-argType (LitTy (StrTyLit s))
- = mkS $ bytesFS s
-argType (TyVarTy x)
- = Just $ F.EVar $ F.symbol $ varName x
-argType t
- | F.symbol (GM.showPpr t) == anyTypeSymbol
- = Just $ F.EVar anyTypeSymbol
-argType _
- = Nothing
-
-
-argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr
-argExpr _ (Var v) = Just $ F.eVar v
-argExpr γ (Lit c) = snd $ literalConst (emb γ) c
-argExpr γ (Tick _ e) = argExpr γ e
-argExpr γ (App e (Type _)) = argExpr γ e
-argExpr _ _ = Nothing
-
-
--- NIKI TODO: merge arg/lam/fun-Expr
-lamExpr :: CGEnv -> CoreExpr -> Maybe F.Expr
-lamExpr _ (Var v) = Just $ F.eVar v
-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 $ F.EApp p1 p2
- (Just p1, Just _ ) -> Just p1
- _ -> Nothing
-lamExpr γ (Let (NonRec x ex) e) = case (lamExpr γ ex, lamExpr γ e) of
- (Just px, Just p) -> Just (p `F.subst1` (F.symbol x, px))
- _ -> Nothing
-lamExpr γ (Lam x e) = case lamExpr γ e of
- Just p -> Just $ F.ELam (F.symbol x, typeSort (emb γ) $ Ghc.expandTypeSynonyms $ varType x) p
- _ -> Nothing
-lamExpr _ _ = Nothing
-
---------------------------------------------------------------------------------
-(??=) :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType
---------------------------------------------------------------------------------
-γ ??= x = case M.lookup x' (lcb γ) of
- Just e -> consE (γ -= x') e
- Nothing -> refreshTy tx
- where
- x' = F.symbol x
- tx = fromMaybe tt (γ ?= x')
- tt = ofType $ varType x
-
-
---------------------------------------------------------------------------------
-varRefType :: (?callStack :: CallStack) => CGEnv -> Var -> CG SpecType
---------------------------------------------------------------------------------
-varRefType γ x = do
- xt <- varRefType' γ x <$> (γ ??= x)
- return xt -- F.tracepp (printf "varRefType x = [%s]" (showpp x))
-
-varRefType' :: CGEnv -> Var -> SpecType -> SpecType
-varRefType' γ x t'
- | Just tys <- trec γ, Just tr <- M.lookup x' tys
- = strengthen tr xr
- | otherwise
- = strengthen t' xr
- where
- xr = singletonReft x
- x' = F.symbol x
- strengthen
- | higherOrderFlag γ
- = strengthenMeet
- | otherwise
- = strengthenTop
-
--- | create singleton types for function application
-makeSingleton :: CGEnv -> CoreExpr -> SpecType -> SpecType
-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)
- -> strengthenMeet t (uTop $ F.exprReft (F.EApp f' x'))
- (Just f', Just _)
- -> strengthenMeet t (uTop $ F.exprReft f')
- _ -> t
- | rankNTypes (getConfig γ)
- = case argExpr γ (simplify e) of
- Just e' -> strengthenMeet t $ (uTop $ F.exprReft e')
- _ -> t
- | otherwise
- = t
- where
- argForAllExpr (Var x)
- | rankNTypes (getConfig γ)
- , Just e <- M.lookup x (forallcb γ)
- = Just e
- argForAllExpr e
- = argExpr γ e
-
-
-
-funExpr :: CGEnv -> CoreExpr -> Maybe F.Expr
-
-funExpr _ (Var v)
- = Just $ F.EVar (F.symbol v)
-
-funExpr γ (App e1 e2)
- = case (funExpr γ e1, argExpr γ e2) of
- (Just e1', Just e2') | not (GM.isPredExpr e2) -- (isClassPred $ exprType e2)
- -> Just (F.EApp e1' e2')
- (Just e1', Just _)
- -> Just e1'
- _ -> Nothing
-
-funExpr _ _
- = Nothing
-
-simplify :: CoreExpr -> CoreExpr
-simplify (Tick _ e) = simplify e
-simplify (App e (Type _)) = simplify e
-simplify (App e1 e2) = App (simplify e1) (simplify e2)
-simplify (Lam x e) | isTyVar x = simplify e
-simplify e = e
-
-
-singletonReft :: (F.Symbolic a) => a -> UReft F.Reft
-singletonReft = uTop . F.symbolReft . F.symbol
-
--- | RJ: `nomeet` replaces `strengthenS` for `strengthen` in the definition
--- of `varRefType`. Why does `tests/neg/strata.hs` fail EVEN if I just replace
--- the `otherwise` case? The fq file holds no answers, both are sat.
-strengthenTop :: (PPrint r, F.Reftable r) => RType c tv r -> r -> RType c tv r
-strengthenTop (RApp c ts rs r) r' = RApp c ts rs $ F.meet r r'
-strengthenTop (RVar a r) r' = RVar a $ F.meet r r'
-strengthenTop (RFun b t1 t2 r) r' = RFun b t1 t2 $ F.meet r r'
-strengthenTop (RAppTy t1 t2 r) r' = RAppTy t1 t2 $ F.meet r r'
-strengthenTop (RAllT a t r) r' = RAllT a t $ F.meet r r'
-strengthenTop t _ = t
-
--- TODO: this is almost identical to RT.strengthen! merge them!
-strengthenMeet :: (PPrint r, F.Reftable r) => RType c tv r -> r -> RType c tv r
-strengthenMeet (RApp c ts rs r) r' = RApp c ts rs (r `F.meet` r')
-strengthenMeet (RVar a r) r' = RVar a (r `F.meet` r')
-strengthenMeet (RFun b t1 t2 r) r' = RFun b t1 t2 (r `F.meet` r')
-strengthenMeet (RAppTy t1 t2 r) r' = RAppTy t1 t2 (r `F.meet` r')
-strengthenMeet (RAllT a t r) r' = RAllT a (strengthenMeet t r') (r `F.meet` r')
-strengthenMeet t _ = t
-
--- topMeet :: (PPrint r, F.Reftable r) => r -> r -> r
--- topMeet r r' = r `F.meet` r'
-
---------------------------------------------------------------------------------
--- | Cleaner Signatures For Rec-bindings ---------------------------------------
---------------------------------------------------------------------------------
-exprLoc :: CoreExpr -> Maybe SrcSpan
-exprLoc (Tick tt _) = Just $ GM.tickSrcSpan tt
-exprLoc (App e a) | isType a = exprLoc e
-exprLoc _ = Nothing
-
-isType :: Expr CoreBndr -> Bool
-isType (Type _) = True
-isType a = eqType (exprType a) predType
-
--- | @isGenericVar@ determines whether the @RTyVar@ has no class constraints
-isGenericVar :: RTyVar -> SpecType -> Bool
-isGenericVar α t = all (\(c, α') -> (α'/=α) || isGenericClass c ) (classConstrs t)
- where
- classConstrs t = [(c, ty_var_value α')
- | (c, ts) <- tyClasses t
- , t' <- ts
- , α' <- freeTyVars t']
- isGenericClass c = className c `elem` [ordClassName, eqClassName] -- , functorClassName, monadClassName]
-
--- instance MonadFail CG where
--- fail msg = panic Nothing msg
-
-instance MonadFail Data.Functor.Identity.Identity where
- fail msg = panic Nothing msg
diff --git a/src/Language/Haskell/Liquid/Constraint/Init.hs b/src/Language/Haskell/Liquid/Constraint/Init.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/Init.hs
+++ /dev/null
@@ -1,311 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module defines the representation of Subtyping and WF Constraints,
--- and the code for syntax-directed constraint generation.
-
-module Language.Haskell.Liquid.Constraint.Init (
- initEnv ,
- initCGI,
- ) where
-
-import Prelude hiding (error, undefined)
-import Coercion
-import DataCon
-import CoreSyn
-import Type
-import TyCon
-import Var
-import Id -- hiding (isExportedId)
-import Name hiding (varName)
-import Control.Monad.State
-import Data.Maybe (isNothing, fromMaybe, catMaybes)
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-import qualified Data.List as L
-import Data.Bifunctor
-import qualified Language.Fixpoint.Types as F
-
-import qualified Language.Haskell.Liquid.UX.CTags as Tg
-import Language.Haskell.Liquid.Constraint.Fresh
-import Language.Haskell.Liquid.Constraint.Env
-import Language.Haskell.Liquid.WiredIn (dictionaryVar)
-import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp
-import Language.Haskell.Liquid.GHC.Misc ( idDataConM, hasBaseTypeVar, isDataConId) -- dropModuleNames, simplesymbol)
-import Language.Haskell.Liquid.Misc
-import Language.Fixpoint.Misc
-import Language.Haskell.Liquid.Constraint.Types
-
-import Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars, Def)
-
---------------------------------------------------------------------------------
-initEnv :: TargetInfo -> CG CGEnv
---------------------------------------------------------------------------------
-initEnv info
- = do let tce = gsTcEmbeds (gsName sp)
- let fVars = giImpVars (giSrc info)
- let dcs = filter isConLikeId (snd <$> gsFreeSyms (gsName sp))
- let dcs' = filter isConLikeId fVars
- defaults <- forM fVars $ \x -> liftM (x,) (trueTy $ varType x)
- dcsty <- forM dcs makeDataConTypes
- dcsty' <- forM dcs' makeDataConTypes
- (hs,f0) <- refreshHoles $ grty info -- asserted refinements (for defined vars)
- f0'' <- refreshArgs' =<< grtyTop info -- default TOP reftype (for exported vars without spec)
- let f0' = if notruetypes $ getConfig sp then [] else f0''
- f1 <- refreshArgs' defaults -- default TOP reftype (for all vars)
- f1' <- refreshArgs' $ makeExactDc dcsty -- data constructors
- f2 <- refreshArgs' $ assm info -- assumed refinements (for imported vars)
- f3' <- refreshArgs' =<< recSelectorsTy info -- assumed refinements (for record selectors)
- f3 <- addPolyInfo' <$> (refreshArgs' $ vals gsAsmSigs (gsSig sp)) -- assumed refinedments (with `assume`)
- f40 <- makeExactDc <$> (refreshArgs' $ vals gsCtors (gsData sp)) -- constructor refinements (for measures)
- f5 <- refreshArgs' $ vals gsInSigs (gsSig sp) -- internal refinements (from Haskell measures)
- fi <- refreshArgs' $ catMaybes $ [(x,) . val <$> getMethodType mt | (x, mt) <- gsMethods $ gsSig $ giSpec info ]
- (invs1, f41) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty (gsAutosize (gsTerm sp)) dcs
- (invs2, f42) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty' (gsAutosize (gsTerm sp)) dcs'
- let f4 = mergeDataConTypes tce (mergeDataConTypes tce f40 (f41 ++ f42)) (filter (isDataConId . fst) f2)
- let tx = mapFst F.symbol . addRInv ialias . predsUnify sp
- f6 <- (map tx . addPolyInfo') <$> (refreshArgs' $ vals gsRefSigs (gsSig sp))
- let bs = (tx <$> ) <$> [f0 ++ f0' ++ fi, f1 ++ f1', f2, f3 ++ f3', f4, f5]
- modify $ \s -> s { dataConTys = f4 }
- lt1s <- F.toListSEnv . cgLits <$> get
- let lt2s = [ (F.symbol x, rTypeSort tce t) | (x, t) <- f1' ]
- let tcb = mapSnd (rTypeSort tce) <$> concat bs
- let cbs = giCbs . giSrc $ info
- rTrue <- mapM (mapSndM true) f6
- let γ0 = measEnv sp (head bs) cbs tcb lt1s lt2s (f6 ++ bs!!3) (bs!!5) hs info
- γ <- globalize <$> foldM (+=) γ0 ( [("initEnv", x, y) | (x, y) <- concat $ (rTrue:tail bs)])
- return γ {invs = is (invs1 ++ invs2)}
- where
- sp = giSpec info
- ialias = mkRTyConIAl (gsIaliases (gsData sp))
- vals f = map (mapSnd val) . f
- mapSndM f = \(x,y) -> ((x,) <$> f y)
- makeExactDc dcs = if exactDCFlag info then map strengthenDataConType dcs else dcs
- is autoinv = mkRTyConInv (gsInvariants (gsData sp) ++ ((Nothing,) <$> autoinv))
- addPolyInfo' = if reflection (getConfig info) then map (mapSnd addPolyInfo) else id
-
-addPolyInfo :: SpecType -> SpecType
-addPolyInfo t = mkUnivs (go <$> as) ps t'
- where
- (as, ps, t') = bkUniv t
- pos = tyVarsPosition t'
- go (a,r) = if {- ty_var_value a `elem` ppos pos && -} ty_var_value a `notElem` pneg pos
- then (setRtvPol a False,r)
- else (a,r)
-
-makeDataConTypes :: Var -> CG (Var, SpecType)
-makeDataConTypes x = (x,) <$> (trueTy $ varType x)
-
-makeAutoDecrDataCons :: [(Id, SpecType)] -> S.HashSet TyCon -> [Id] -> ([LocSpecType], [(Id, SpecType)])
-makeAutoDecrDataCons dcts specenv dcs
- = (simplify invs, tys)
- where
- (invs, tys) = unzip $ concatMap go tycons
- tycons = L.nub $ catMaybes $ map idTyCon dcs
-
- go tycon
- | S.member tycon specenv = zipWith (makeSizedDataCons dcts) (tyConDataCons tycon) [0..]
- go _
- = []
-
- simplify invs = dummyLoc . (`strengthen` invariant) . fmap (\_ -> mempty) <$> L.nub invs
- invariant = MkUReft (F.Reft (F.vv_, F.PAtom F.Ge (lenOf F.vv_) (F.ECon $ F.I 0)) ) mempty
-
-idTyCon :: Id -> Maybe TyCon
-idTyCon = fmap dataConTyCon . idDataConM
-
-lenOf :: F.Symbol -> F.Expr
-lenOf x = F.mkEApp lenLocSymbol [F.EVar x]
-
-makeSizedDataCons :: [(Id, SpecType)] -> DataCon -> Integer -> (RSort, (Id, SpecType))
-makeSizedDataCons dcts x' n = (toRSort $ ty_res trep, (x, fromRTypeRep trep{ty_res = tres}))
- where
- x = dataConWorkId x'
- t = fromMaybe (impossible Nothing "makeSizedDataCons: this should never happen") $ L.lookup x dcts
- trep = toRTypeRep t
- tres = ty_res trep `strengthen` MkUReft (F.Reft (F.vv_, F.PAtom F.Eq (lenOf F.vv_) computelen)) mempty
-
- recarguments = filter (\(t,_) -> (toRSort t == toRSort tres)) (zip (ty_args trep) (ty_binds trep))
- computelen = foldr (F.EBin F.Plus) (F.ECon $ F.I n) (lenOf . snd <$> recarguments)
-
-mergeDataConTypes :: F.TCEmb TyCon -> [(Var, SpecType)] -> [(Var, SpecType)] -> [(Var, SpecType)]
-mergeDataConTypes tce xts yts = merge (L.sortBy f xts) (L.sortBy f yts)
- where
- f (x,_) (y,_) = compare x y
- merge [] ys = ys
- merge xs [] = xs
- merge (xt@(x, tx):xs) (yt@(y, ty):ys)
- | x == y = (x, mXY x tx y ty) : merge xs ys
- | x < y = xt : merge xs (yt : ys)
- | otherwise = yt : merge (xt : xs) ys
- mXY x tx y ty = meetVarTypes tce (F.pprint x) (getSrcSpan x, tx) (getSrcSpan y, ty)
-
-refreshArgs' :: [(a, SpecType)] -> CG [(a, SpecType)]
-refreshArgs' = mapM (mapSndM refreshArgs)
-
-
--- | TODO: All this *should* happen inside @Bare@ but appears
--- to happen after certain are signatures are @fresh@-ed,
--- which is why they are here.
-
--- NV : still some sigs do not get TyConInfo
-
-predsUnify :: TargetSpec -> (Var, RRType RReft) -> (Var, RRType RReft)
-predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@
- where
- tce = gsTcEmbeds (gsName sp)
- tyi = gsTyconEnv (gsName sp)
-
-
---------------------------------------------------------------------------------
-measEnv :: TargetSpec
- -> [(F.Symbol, SpecType)]
- -> [CoreBind]
- -> [(F.Symbol, F.Sort)]
- -> [(F.Symbol, F.Sort)]
- -> [(F.Symbol, F.Sort)]
- -> [(F.Symbol, SpecType)]
- -> [(F.Symbol, SpecType)]
- -> [F.Symbol]
- -> TargetInfo
- -> CGEnv
---------------------------------------------------------------------------------
-measEnv sp xts cbs _tcb lt1s lt2s asms itys hs info = CGE
- { cgLoc = Sp.empty
- , renv = fromListREnv (second val <$> gsMeas (gsData sp)) []
- , syenv = F.fromListSEnv (gsFreeSyms (gsName sp))
- , litEnv = F.fromListSEnv lts
- , constEnv = F.fromListSEnv lt2s
- , fenv = initFEnv $ filterHO (tcb' ++ lts ++ (second (rTypeSort tce . val) <$> gsMeas (gsData sp)))
- , denv = dmapty val $ gsDicts (gsSig sp)
- , recs = S.empty
- , invs = mempty
- , rinvs = mempty
- , ial = mkRTyConIAl (gsIaliases (gsData sp))
- , grtys = fromListREnv xts []
- , assms = fromListREnv asms []
- , intys = fromListREnv itys []
- , emb = tce
- , tgEnv = Tg.makeTagEnv cbs
- , tgKey = Nothing
- , trec = Nothing
- , lcb = M.empty
- , forallcb = M.empty
- , holes = fromListHEnv hs
- , lcs = mempty
- , cerr = Nothing
- , cgInfo = info
- , cgVar = Nothing
- }
- where
- tce = gsTcEmbeds (gsName sp)
- filterHO xs = if higherOrderFlag sp then xs else filter (F.isFirstOrder . snd) xs
- lts = lt1s ++ lt2s
- tcb' = []
-
-
-assm :: TargetInfo -> [(Var, SpecType)]
-assm = assmGrty (giImpVars . giSrc)
-
-grty :: TargetInfo -> [(Var, SpecType)]
-grty = assmGrty (giDefVars . giSrc)
-
-assmGrty :: (TargetInfo -> [Var]) -> TargetInfo -> [(Var, SpecType)]
-assmGrty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ]
- where
- xs = S.fromList . f $ info
- sigs = gsTySigs . gsSig . giSpec $ info
-
-
-recSelectorsTy :: TargetInfo -> CG [(Var, SpecType)]
-recSelectorsTy info = forM topVs $ \v -> (v,) <$> trueTy (varType v)
- where
- topVs = filter isTop $ giDefVars (giSrc info)
- isTop v = isExportedVar (giSrc info) v && not (v `S.member` sigVs) && isRecordSelector v
- sigVs = S.fromList [v | (v,_) <- gsTySigs sp ++ gsAsmSigs sp ++ gsRefSigs sp ++ gsInSigs sp]
- sp = gsSig . giSpec $ info
-
-
-
-grtyTop :: TargetInfo -> CG [(Var, SpecType)]
-grtyTop info = forM topVs $ \v -> (v,) <$> trueTy (varType v)
- where
- topVs = filter isTop $ giDefVars (giSrc info)
- isTop v = isExportedVar (giSrc info) v && not (v `S.member` sigVs) && not (isRecordSelector v)
- sigVs = S.fromList [v | (v,_) <- gsTySigs sp ++ gsAsmSigs sp ++ gsRefSigs sp ++ gsInSigs sp]
- sp = gsSig . giSpec $ info
-
-
-infoLits :: (TargetSpec -> [(F.Symbol, LocSpecType)]) -> (F.Sort -> Bool) -> TargetInfo -> F.SEnv F.Sort
-infoLits litF selF info = F.fromListSEnv $ cbLits ++ measLits
- where
- cbLits = filter (selF . snd) $ coreBindLits tce info
- measLits = filter (selF . snd) $ mkSort <$> litF spc
- spc = giSpec info
- tce = gsTcEmbeds (gsName spc)
- mkSort = mapSnd (F.sr_sort . rTypeSortedReft tce . val)
-
-initCGI :: Config -> TargetInfo -> CGInfo
-initCGI cfg info = CGInfo {
- fEnv = F.emptySEnv
- , hsCs = []
- , hsWfs = []
- , fixCs = []
- , fixWfs = []
- , freshIndex = 0
- , dataConTys = []
- , binds = F.emptyBindEnv
- , ebinds = []
- , annotMap = AI M.empty
- , holesMap = M.empty
- , newTyEnv = M.fromList (mapSnd val <$> gsNewTypes (gsSig spc))
- , tyConInfo = tyi
- , tyConEmbed = tce
- , kuts = mempty
- , kvPacks = mempty
- , cgLits = infoLits (gsMeas . gsData) (const True) info
- , cgConsts = infoLits (gsMeas . gsData) notFn info
- , cgADTs = gsADTs nspc
- , termExprs = M.fromList [(v, es) | (v, _, es) <- gsTexprs (gsSig spc) ]
- , specDecr = gsDecr tspc
- , specLVars = gsLvars (gsVars spc)
- , specLazy = dictionaryVar `S.insert` (gsLazy tspc)
- , specTmVars = gsNonStTerm tspc
- , tcheck = terminationCheck cfg
- , pruneRefs = pruneUnsorted cfg
- , logErrors = []
- , kvProf = emptyKVProf
- , recCount = 0
- , bindSpans = M.empty
- , autoSize = gsAutosize tspc
- , allowHO = higherOrderFlag cfg
- , ghcI = info
- , unsorted = F.notracepp "UNSORTED" $ F.makeTemplates $ gsUnsorted $ gsData spc
- }
- where
- tce = gsTcEmbeds nspc
- tspc = gsTerm spc
- spc = giSpec info
- tyi = gsTyconEnv nspc
- nspc = gsName spc
- notFn = isNothing . F.functionSort
-
-coreBindLits :: F.TCEmb TyCon -> TargetInfo -> [(F.Symbol, F.Sort)]
-coreBindLits tce info
- = sortNub $ [ (F.symbol x, F.strSort) | (_, Just (F.ESym x)) <- lconsts ] -- strings
- ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons ] -- data constructors
- where
- src = giSrc info
- lconsts = literalConst tce <$> literals (giCbs src)
- dcons = filter isDCon freeVs
- freeVs = giImpVars src ++ freeSyms
- freeSyms = fmap snd . gsFreeSyms . gsName . giSpec $ info
- dconToSort = typeSort tce . expandTypeSynonyms . varType
- dconToSym = F.symbol . idDataCon
- isDCon x = isDataConId x && not (hasBaseTypeVar x)
diff --git a/src/Language/Haskell/Liquid/Constraint/Monad.hs b/src/Language/Haskell/Liquid/Constraint/Monad.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/Monad.hs
+++ /dev/null
@@ -1,150 +0,0 @@
--- | This module contains various functions that add/update in the CG monad.
-
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-module Language.Haskell.Liquid.Constraint.Monad where
-
-import Var
-import Name (getSrcSpan)
-import SrcLoc
-import Outputable hiding (showPpr, panic, (<>), showSDoc, text)
-
-import qualified TyCon as TC
-
-import qualified Data.HashMap.Strict as M
-import qualified Data.Text as T
-
-import Control.Monad
-import Control.Monad.State (get, modify)
-import Language.Haskell.Liquid.Types hiding (loc)
-import Language.Haskell.Liquid.Constraint.Types
-import Language.Haskell.Liquid.Constraint.Env
-import Language.Fixpoint.Misc hiding (errorstar)
-import Language.Haskell.Liquid.GHC.Misc -- (concatMapM)
-import Language.Haskell.Liquid.GHC.SpanStack (srcSpan)
-
---------------------------------------------------------------------------------
--- | `addC` adds a subtyping constraint into the global pool.
---------------------------------------------------------------------------------
-addC :: SubC -> String -> CG ()
---------------------------------------------------------------------------------
-addC c@(SubC γ t1 t2) _msg
- | toType t1 /= toType t2
- = panic (Just $ getLocation γ) $ "addC: malformed constraint:\n" ++ _msg ++ showpp t1 ++ "\n <: \n" ++ showpp t2
- | otherwise
- = modify $ \s -> s { hsCs = c : (hsCs s) }
-
-
-addC c _msg
- = modify $ \s -> s { hsCs = c : hsCs s }
-
---------------------------------------------------------------------------------
--- | addPost: RJ: what DOES this function do?
---------------------------------------------------------------------------------
-addPost :: CGEnv -> SpecType -> CG SpecType
---------------------------------------------------------------------------------
-addPost γ (RRTy e r OInv t)
- = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) γ e
- addC (SubR γ' OInv r) "precondition-oinv" >> return t
-
-addPost γ (RRTy e r OTerm t)
- = do γ' <- foldM (\γ (x, t) -> γ += ("addPost", x, t)) γ e
- addC (SubR γ' OTerm r) "precondition-oterm" >> return t
-
-addPost γ (RRTy cts _ OCons t)
- = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts
- addC (SubC γ' t1 t2) "precondition-ocons"
- addPost γ t
- where
- (xts, t1, t2) = envToSub cts
-addPost _ t
- = return t
-
---------------------------------------------------------------------------------
--- | Add Well formedness Constraint
---------------------------------------------------------------------------------
-addW :: WfC -> CG ()
---------------------------------------------------------------------------------
-addW !w = modify $ \s -> s { hsWfs = w : (hsWfs s) }
-
---------------------------------------------------------------------------------
--- | Add a warning
---------------------------------------------------------------------------------
-addWarning :: Error -> CG ()
---------------------------------------------------------------------------------
-addWarning w = modify $ \s -> s { logErrors = w : logErrors s }
-
--- | Add Identifier Annotations, used for annotation binders (i.e. at binder sites)
-addIdA :: Var -> Annot SpecType -> CG ()
-addIdA !x !t = modify $ \s -> s { annotMap = upd $ annotMap s }
- where
- l = getSrcSpan x
- upd m@(AI _) = if boundRecVar l m then m else addA l (Just x) t m
-
-boundRecVar :: SrcSpan -> AnnInfo (Annot a) -> Bool
-boundRecVar l (AI m) = not $ null [t | (_, AnnRDf t) <- M.lookupDefault [] l m]
-
-
--- | Used for annotating reads (i.e. at Var x sites)
-
-addLocA :: Maybe Var -> SrcSpan -> Annot SpecType -> CG ()
-addLocA !xo !l !t
- = modify $ \s -> s { annotMap = addA l xo t $ annotMap s }
-
-
--- | Used for annotating holes
-
-addHole :: Var -> SpecType -> CGEnv -> CG ()
-addHole x t γ
- | typedHoles (getConfig γ) =
- do st <- get
- modify $ \s -> s {holesMap = M.insert x (hinfo (st, γ)) $ holesMap s}
- -- addWarning $ ErrHole loc ("hole found") (reGlobal env <> reLocal env) x' t
- | otherwise = return ()
- where
- hinfo = HoleInfo t loc env
- loc = srcSpan $ cgLoc γ
- env = mconcat [renv γ, grtys γ, assms γ, intys γ]
-
---------------------------------------------------------------------------------
--- | Update annotations for a location, due to (ghost) predicate applications
---------------------------------------------------------------------------------
-updateLocA :: Maybe SrcSpan -> SpecType -> CG ()
---------------------------------------------------------------------------------
-updateLocA (Just l) t = addLocA Nothing l (AnnUse t)
-updateLocA _ _ = return ()
---------------------------------------------------------------------------------
-
---------------------------------------------------------------------------------
-addA :: (Outputable a) => SrcSpan -> Maybe a -> b -> AnnInfo b -> AnnInfo b
---------------------------------------------------------------------------------
-addA !l xo@(Just _) !t (AI m)
- | isGoodSrcSpan l
- = AI $ inserts l (T.pack . showPpr <$> xo, t) m
-addA !l xo@Nothing !t (AI m)
- | l `M.member` m -- only spans known to be variables
- = AI $ inserts l (T.pack . showPpr <$> xo, t) m
-addA _ _ _ !a
- = a
-
-
-lookupNewType :: TC.TyCon -> CG (Maybe SpecType)
-lookupNewType tc
- = M.lookup tc . newTyEnv <$> get
-
-
---------------------------------------------------------------------------------
-{-@ envToSub :: {v:[(a, b)] | 2 <= len v} -> ([(a, b)], b, b) @-}
-envToSub :: [(a, b)] -> ([(a, b)], b, b)
---------------------------------------------------------------------------------
-envToSub = go []
- where
- go _ [] = impossible Nothing "This cannot happen: envToSub on 0 elems"
- go _ [(_,_)] = impossible Nothing "This cannot happen: envToSub on 1 elem"
- go ack [(_,l), (_, r)] = (reverse ack, l, r)
- go ack (x:xs) = go (x:ack) xs
diff --git a/src/Language/Haskell/Liquid/Constraint/Qualifier.hs b/src/Language/Haskell/Liquid/Constraint/Qualifier.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/Qualifier.hs
+++ /dev/null
@@ -1,244 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-
-module Language.Haskell.Liquid.Constraint.Qualifier
- ( giQuals
- , useSpcQuals
- )
- where
-
-import Prelude hiding (error)
-import Data.List (delete, nub)
-import Data.Maybe (isJust, catMaybes, fromMaybe, isNothing)
-import qualified Data.HashSet as S
-import qualified Data.HashMap.Strict as M
-import Debug.Trace (trace)
-import TyCon
-import Var (Var)
-import Language.Fixpoint.Types hiding (panic, mkQual)
-import qualified Language.Fixpoint.Types.Config as FC
-import Language.Fixpoint.SortCheck
-import Language.Haskell.Liquid.Types.RefType
-import Language.Haskell.Liquid.GHC.Misc (getSourcePos)
-import Language.Haskell.Liquid.Misc (condNull)
-import Language.Haskell.Liquid.Types.PredType
-
-import Language.Haskell.Liquid.Types
-
-
---------------------------------------------------------------------------------
-giQuals :: TargetInfo -> SEnv Sort -> [Qualifier]
---------------------------------------------------------------------------------
-giQuals info lEnv
- = notracepp ("GI-QUALS: " ++ showpp lEnv)
- $ condNull (useSpcQuals info) (gsQualifiers . gsQual . giSpec $ info)
- ++ condNull (useSigQuals info) (sigQualifiers info lEnv)
- ++ condNull (useAlsQuals info) (alsQualifiers info lEnv)
-
--- --------------------------------------------------------------------------------
--- qualifiers :: GhcInfo -> SEnv Sort -> [Qualifier]
--- --------------------------------------------------------------------------------
--- qualifiers info env = spcQs ++ genQs
- -- where
- -- spcQs = gsQualifiers spc
- -- genQs = specificationQualifiers info env
- -- n = maxParams (getConfig spc)
- -- spc = spec info
-
-maxQualParams :: (HasConfig t) => t -> Int
-maxQualParams = maxParams . getConfig
-
--- | Use explicitly given qualifiers .spec or source (.hs, .lhs) files
-useSpcQuals :: (HasConfig t) => t -> Bool
-useSpcQuals i = useQuals i && not (useAlsQuals i)
-
--- | Scrape qualifiers from function signatures (incr :: x:Int -> {v:Int | v > x})
-useSigQuals :: (HasConfig t) => t -> Bool
-useSigQuals i = useQuals i && not (useAlsQuals i)
-
--- | Scrape qualifiers from refinement type aliases (type Nat = {v:Int | 0 <= 0})
-useAlsQuals :: (HasConfig t) => t -> Bool
-useAlsQuals i = useQuals i && i `hasOpt` higherOrderFlag && not (needQuals i)
-
-useQuals :: (HasConfig t) => t -> Bool
-useQuals = not . (FC.All == ) . eliminate . getConfig
-
-needQuals :: (HasConfig t) => t -> Bool
-needQuals = (FC.None == ) . eliminate . getConfig
-
---------------------------------------------------------------------------------
-alsQualifiers :: TargetInfo -> SEnv Sort -> [Qualifier]
---------------------------------------------------------------------------------
-alsQualifiers info lEnv
- = [ q | a <- gsRTAliases . gsQual . giSpec $ info
- , q <- refTypeQuals lEnv (loc a) tce (rtBody (val a))
- , length (qParams q) <= k + 1
- , validQual lEnv q
- ]
- where
- k = maxQualParams info
- tce = gsTcEmbeds . gsName . giSpec $ info
-
-validQual :: SEnv Sort -> Qualifier -> Bool
-validQual lEnv q = isJust $ checkSortExpr (srcSpan q) env (qBody q)
- where
- env = unionSEnv lEnv qEnv
- qEnv = M.fromList (qualBinds q)
-
-
---------------------------------------------------------------------------------
-sigQualifiers :: TargetInfo -> SEnv Sort -> [Qualifier]
---------------------------------------------------------------------------------
-sigQualifiers info lEnv
- = [ q | (x, t) <- specBinders info
- , x `S.member` qbs
- , q <- refTypeQuals lEnv (getSourcePos x) tce (val t)
- -- NOTE: large qualifiers are VERY expensive, so we only mine
- -- qualifiers up to a given size, controlled with --max-params
- , length (qParams q) <= k + 1
- ]
- where
- k = maxQualParams info
- tce = gsTcEmbeds . gsName . giSpec $ info
- qbs = qualifyingBinders info
-
-qualifyingBinders :: TargetInfo -> S.HashSet Var
-qualifyingBinders info = S.difference sTake sDrop
- where
- sTake = S.fromList $ giDefVars src ++ giUseVars src ++ scrapeVars cfg src
- sDrop = S.fromList $ specAxiomVars info
- cfg = getConfig info
- src = giSrc info
-
--- NOTE: this mines extra, useful qualifiers but causes
--- a significant increase in running time, so we hide it
--- behind `--scrape-imports` and `--scrape-used-imports`
-scrapeVars :: Config -> TargetSrc -> [Var]
-scrapeVars cfg src
- | cfg `hasOpt` scrapeUsedImports = giUseVars src
- | cfg `hasOpt` scrapeImports = giImpVars src
- | otherwise = []
-
-specBinders :: TargetInfo -> [(Var, LocSpecType)]
-specBinders info = mconcat
- [ gsTySigs (gsSig sp)
- , gsAsmSigs (gsSig sp)
- , gsRefSigs (gsSig sp)
- , gsCtors (gsData sp)
- , if info `hasOpt` scrapeInternals then gsInSigs (gsSig sp) else []
- ]
- where
- sp = giSpec info
-
-specAxiomVars :: TargetInfo -> [Var]
-specAxiomVars = gsReflects . gsRefl . giSpec
-
--- GRAVEYARD: scraping quals from imports kills the system with too much crap
--- specificationQualifiers info = {- filter okQual -} qs
--- where
--- qs = concatMap refTypeQualifiers ts
--- refTypeQualifiers = refTypeQuals $ tcEmbeds spc
--- ts = val <$> t1s ++ t2s
--- t1s = [t | (x, t) <- tySigs spc, x `S.member` definedVars]
--- t2s = [] -- [t | (_, t) <- ctor spc ]
--- definedVars = S.fromList $ defVars info
--- spc = spec info
---
--- okQual = not . any isPred . map snd . q_params
--- where
--- isPred (FApp tc _) = tc == stringFTycon "Pred"
--- isPred _ = False
-
-
--- TODO: rewrite using foldReft'
---------------------------------------------------------------------------------
-refTypeQuals :: SEnv Sort -> SourcePos -> TCEmb TyCon -> SpecType -> [Qualifier]
---------------------------------------------------------------------------------
-refTypeQuals lEnv l tce t0 = go emptySEnv t0
- where
- scrape = refTopQuals lEnv l tce t0
- add x t γ = insertSEnv x (rTypeSort tce t) γ
- goBind x t γ t' = go (add x t γ) t'
- go γ t@(RVar _ _) = scrape γ t
- go γ (RAllT _ t _) = go γ t
- go γ (RAllP p t) = go (insertSEnv (pname p) (rTypeSort tce $ (pvarRType p :: RSort)) γ) t
- go γ t@(RAppTy t1 t2 _) = go γ t1 ++ go γ t2 ++ scrape γ t
- go γ (RFun x t t' _) = go γ t ++ goBind x t γ t'
- go γ t@(RApp c ts rs _) = scrape γ t ++ concatMap (go γ') ts ++ goRefs c γ' rs
- where γ' = add (rTypeValueVar t) t γ
- go γ (RAllE x t t') = go γ t ++ goBind x t γ t'
- go γ (REx x t t') = go γ t ++ goBind x t γ t'
- go _ _ = []
- goRefs c g rs = concat $ zipWith (goRef g) rs (rTyConPVs c)
- goRef _ (RProp _ (RHole _)) _ = []
- goRef g (RProp s t) _ = go (insertsSEnv g s) t
- insertsSEnv = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ)
-
-
-refTopQuals :: (PPrint t, Reftable t, SubsTy RTyVar RSort t, Reftable (RTProp RTyCon RTyVar (UReft t)))
- => SEnv Sort
- -> SourcePos
- -> TCEmb TyCon
- -> RType RTyCon RTyVar r
- -> SEnv Sort
- -> RRType (UReft t)
- -> [Qualifier]
-refTopQuals lEnv l tce t0 γ t
- = [ mkQ v so pa | let (RR so (Reft (v, ra))) = rTypeSortedReft tce t
- , pa <- conjuncts ra
- , not $ isHole pa
- , not $ isGradual pa
- , notracepp ("refTopQuals: " ++ showpp pa)
- $ isNothing $ checkSorted (srcSpan l) (insertSEnv v so γ') pa
- ]
- ++
- [ mkP s e | let (MkUReft _ (Pr ps)) = fromMaybe (msg t) $ stripRTypeBase t
- , p <- findPVar (ty_preds $ toRTypeRep t0) <$> ps
- , (s, _, e) <- pargs p
- ]
- where
- mkQ = mkQual lEnv l t0 γ
- mkP = mkPQual lEnv l tce t0 γ
- msg t = panic Nothing $ "Qualifier.refTopQuals: no typebase" ++ showpp t
- γ' = unionSEnv' γ lEnv
-
-mkPQual :: (PPrint r, Reftable r, SubsTy RTyVar RSort r, Reftable (RTProp RTyCon RTyVar r))
- => SEnv Sort
- -> SourcePos
- -> TCEmb TyCon
- -> t
- -> SEnv Sort
- -> RRType r
- -> Expr
- -> Qualifier
-mkPQual lEnv l tce t0 γ t e = mkQual lEnv l t0 γ' v so pa
- where
- v = "vv"
- so = rTypeSort tce t
- γ' = insertSEnv v so γ
- pa = PAtom Eq (EVar v) e
-
-mkQual :: SEnv Sort
- -> SourcePos
- -> t
- -> SEnv Sort
- -> Symbol
- -> Sort
- -> Expr
- -> Qualifier
-mkQual lEnv l _ γ v so p = mkQ "Auto" ((v, so) : xts) p l
- where
- xs = delete v $ nub $ syms p
- xts = catMaybes $ zipWith (envSort l lEnv γ) xs [0..]
-
-envSort :: SourcePos -> SEnv Sort -> SEnv Sort -> Symbol -> Integer -> Maybe (Symbol, Sort)
-envSort l lEnv tEnv x i
- | Just t <- lookupSEnv x tEnv = Just (x, t)
- | Just _ <- lookupSEnv x lEnv = Nothing
- | otherwise = Just (x, ai)
- where
- ai = trace msg $ fObj $ Loc l l $ tempSymbol "LHTV" i
- msg = "Unknown symbol in qualifier: " ++ show x
diff --git a/src/Language/Haskell/Liquid/Constraint/Split.hs b/src/Language/Haskell/Liquid/Constraint/Split.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/Split.hs
+++ /dev/null
@@ -1,446 +0,0 @@
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-
---------------------------------------------------------------------------------
--- | Constraint Splitting ------------------------------------------------------
---------------------------------------------------------------------------------
-
-module Language.Haskell.Liquid.Constraint.Split (
-
- -- * Split Subtyping Constraints
- splitC
-
- -- * Split Well-formedness Constraints
- , splitW
-
- -- * ???
- , envToSub
-
- -- * Panic
- , panicUnbound
- ) where
-
-import Prelude hiding (error)
-
-
-
-import Text.PrettyPrint.HughesPJ hiding (first, parens)
-
-import Data.Maybe (fromMaybe)
-import Control.Monad
-import Control.Monad.State (get)
-import qualified Control.Exception as Ex
-
-import qualified Language.Fixpoint.Types as F
-import Language.Fixpoint.Misc hiding (errorstar)
-import Language.Fixpoint.SortCheck (pruneUnsortedReft)
-
-import Language.Haskell.Liquid.Misc -- (concatMapM)
-import qualified Language.Haskell.Liquid.UX.CTags as Tg
-import Language.Haskell.Liquid.Types hiding (loc)
-
-
-import Language.Haskell.Liquid.Constraint.Types
-import Language.Haskell.Liquid.Constraint.Env
-import Language.Haskell.Liquid.Constraint.Constraint
-import Language.Haskell.Liquid.Constraint.Monad (envToSub)
-
---------------------------------------------------------------------------------
-splitW :: WfC -> CG [FixWfC]
---------------------------------------------------------------------------------
-splitW (WfC γ t@(RFun x t1 t2 _))
- = do ws' <- splitW (WfC γ t1)
- γ' <- γ += ("splitW", x, t1)
- ws <- bsplitW γ t
- ws'' <- splitW (WfC γ' t2)
- return $ ws ++ ws' ++ ws''
-
-splitW (WfC γ t@(RImpF x t1 t2 _))
- = do ws' <- splitW (WfC γ t1)
- γ' <- γ += ("splitW", x, t1)
- ws <- bsplitW γ t
- ws'' <- splitW (WfC γ' t2)
- return $ ws ++ ws' ++ ws''
-
-
-splitW (WfC γ t@(RAppTy t1 t2 _))
- = do ws <- bsplitW γ t
- ws' <- splitW (WfC γ t1)
- ws'' <- splitW (WfC γ t2)
- return $ ws ++ ws' ++ ws''
-
-splitW (WfC γ t'@(RAllT a t _))
- = do γ' <- updateEnv γ a
- ws <- bsplitW γ t'
- ws' <- splitW (WfC γ' t)
- return $ ws ++ ws'
-
-splitW (WfC γ (RAllP _ r))
- = splitW (WfC γ r)
-
-splitW (WfC γ t@(RVar _ _))
- = bsplitW γ t
-
-splitW (WfC γ t@(RApp _ ts rs _))
- = do ws <- bsplitW γ t
- γ' <- if bscope (getConfig γ) then γ `extendEnvWithVV` t else return γ
- ws' <- concat <$> mapM (splitW . WfC γ') ts
- ws'' <- concat <$> mapM (rsplitW γ) rs
- return $ ws ++ ws' ++ ws''
-
-splitW (WfC γ (RAllE x tx t))
- = do ws <- splitW (WfC γ tx)
- γ' <- γ += ("splitW1", x, tx)
- ws' <- splitW (WfC γ' t)
- return $ ws ++ ws'
-
-splitW (WfC γ (REx x tx t))
- = do ws <- splitW (WfC γ tx)
- γ' <- γ += ("splitW2", x, tx)
- ws' <- splitW (WfC γ' t)
- return $ ws ++ ws'
-
-splitW (WfC γ (RRTy _ _ _ t))
- = splitW (WfC γ t)
-
-splitW (WfC _ t)
- = panic Nothing $ "splitW cannot handle: " ++ showpp t
-
-rsplitW :: CGEnv
- -> Ref RSort SpecType
- -> CG [FixWfC]
-rsplitW _ (RProp _ (RHole _)) =
- panic Nothing "Constrains: rsplitW for RProp _ (RHole _)"
-
-rsplitW γ (RProp ss t0) = do
- γ' <- foldM (+=) γ [("rsplitW", x, ofRSort s) | (x, s) <- ss]
- splitW $ WfC γ' t0
-
-
-bsplitW :: CGEnv -> SpecType -> CG [FixWfC]
-bsplitW γ t =
- do temp <- getTemplates
- isHO <- allowHO <$> get
- return $ bsplitW' γ t temp isHO
-
-bsplitW' :: (PPrint r, F.Reftable r, SubsTy RTyVar RSort r, F.Reftable (RTProp RTyCon RTyVar r))
- => CGEnv -> RRType r -> F.Templates -> Bool -> [F.WfC Cinfo]
-bsplitW' γ t temp isHO
- | isHO || F.isNonTrivial r'
- = F.wfC (feBinds $ fenv γ) r' ci
- | otherwise
- = []
- where
- r' = rTypeSortedReft' γ temp t
- ci = Ci (getLocation γ) Nothing (cgVar γ)
-
-splitfWithVariance :: Applicative f
- => (t -> t -> f [a]) -> t -> t -> Variance -> f [a]
-splitfWithVariance f t1 t2 Invariant = (++) <$> f t1 t2 <*> f t2 t1
-splitfWithVariance f t1 t2 Bivariant = (++) <$> f t1 t2 <*> f t2 t1
-splitfWithVariance f t1 t2 Covariant = f t1 t2
-splitfWithVariance f t1 t2 Contravariant = f t2 t1
-
-updateEnv :: CGEnv -> RTVar RTyVar (RType RTyCon RTyVar b0) -> CG CGEnv
-updateEnv γ a
- | Just (x, s) <- rTVarToBind a
- = γ += ("splitS RAllT", x, fmap (const mempty) s)
- | otherwise
- = return γ
-
-------------------------------------------------------------
-splitC :: SubC -> CG [FixSubC]
-------------------------------------------------------------
-
-splitC (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2
- = do γ' <- γ += ("addExBind 0", x, forallExprRefType γ tx)
- splitC (SubC γ' t1 t2)
-
-splitC (SubC γ t1 (REx x tx t2))
- = do y <- fresh
- γ' <- γ += ("addExBind 1", y, forallExprRefType γ tx)
- splitC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))
-
--- existential at the left hand side is treated like forall
-splitC (SubC γ (REx x tx t1) t2)
- = do -- let tx' = traceShow ("splitC: " ++ showpp z) tx
- y <- fresh
- γ' <- γ += ("addExBind 2", y, forallExprRefType γ tx)
- splitC (SubC γ' (F.subst1 t1 (x, F.EVar y)) t2)
-
-splitC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2
- = do γ' <- γ += ("addAllBind 3", x, forallExprRefType γ tx)
- splitC (SubC γ' t1 t2)
-
-splitC (SubC γ (RAllE x tx t1) t2)
- = do y <- fresh
- γ' <- γ += ("addAABind 1", y, forallExprRefType γ tx)
- splitC (SubC γ' (t1 `F.subst1` (x, F.EVar y)) t2)
-
-splitC (SubC γ t1 (RAllE x tx t2))
- = do y <- fresh
- γ' <- γ += ("addAllBind 2", y, forallExprRefType γ tx)
- splitC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y)))
-
-splitC (SubC γ (RRTy env _ OCons t1) t2)
- = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts
- c1 <- splitC (SubC γ' t1' t2')
- c2 <- splitC (SubC γ t1 t2 )
- return $ c1 ++ c2
- where
- (xts, t1', t2') = envToSub env
-
-splitC (SubC γ (RRTy e r o t1) t2)
- = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e
- c1 <- splitC (SubR γ' o r)
- c2 <- splitC (SubC γ t1 t2)
- return $ c1 ++ c2
-
-splitC (SubC γ (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2))
- = do cs' <- splitC (SubC γ t2 t1)
- γ' <- γ+= ("splitC", x2, t2)
- cs <- bsplitC γ (RFun x1 t1 t1' (r1 `F.subst1` (x1, F.EVar x2)))
- (RFun x2 t2 t2' r2)
- let t1x2' = t1' `F.subst1` (x1, F.EVar x2)
- cs'' <- splitC (SubC γ' t1x2' t2')
- return $ cs ++ cs' ++ cs''
-
-splitC (SubC γ (RImpF x1 t1 t1' r1) (RImpF x2 t2 t2' r2))
- = do cs' <- splitC (SubC γ t2 t1)
- γ' <- γ+= ("splitC", x2, t2)
- cs <- bsplitC γ (RImpF x1 t1 t1' (r1 `F.subst1` (x1, F.EVar x2)))
- (RImpF x2 t2 t2' r2)
- let t1x2' = t1' `F.subst1` (x1, F.EVar x2)
- cs'' <- splitC (SubC γ' t1x2' t2')
- return $ cs ++ cs' ++ cs''
-
-
-splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _))
- = do cs <- bsplitC γ t1 t2
- cs' <- splitC (SubC γ r1 r2)
- cs'' <- splitC (SubC γ r1' r2')
- cs''' <- splitC (SubC γ r2' r1')
- return $ cs ++ cs' ++ cs'' ++ cs'''
-
-splitC (SubC γ t1 (RAllP p t))
- = splitC $ SubC γ t1 t'
- where
- t' = fmap (replacePredsWithRefs su) t
- su = (uPVar p, pVartoRConc p)
-
-splitC (SubC γ t1@(RAllP _ _) t2)
- = panic (Just $ getLocation γ) $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2
-
-splitC (SubC γ t1'@(RAllT α1 t1 _) t2'@(RAllT α2 t2 _))
- | α1 == α2
- = do γ' <- updateEnv γ α2
- cs <- bsplitC γ t1' t2'
- cs' <- splitC $ SubC γ' t1 (F.subst su t2)
- return (cs ++ cs')
- | otherwise
- = do γ' <- updateEnv γ α2
- cs <- bsplitC γ t1' t2'
- cs' <- splitC $ SubC γ' t1 (F.subst su t2'')
- return (cs ++ cs')
- where
- t2'' = subsTyVar_meet' (ty_var_value α2, RVar (ty_var_value α1) mempty) t2
- su = case (rTVarToBind α1, rTVarToBind α2) of
- (Just (x1, _), Just (x2, _)) -> F.mkSubst [(x1, F.EVar x2)]
- _ -> F.mkSubst []
-
-splitC (SubC _ (RApp c1 _ _ _) (RApp c2 _ _ _)) | isClass c1 && c1 == c2
- = return []
-
-splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))
- = do (t1',t2') <- unifyVV t1 t2
- cs <- bsplitC γ t1' t2'
- γ' <- if (bscope (getConfig γ)) then γ `extendEnvWithVV` t1' else return γ
- let RApp c t1s r1s _ = t1'
- let RApp _ t2s r2s _ = t2'
- let isapplied = True -- TC.tyConArity (rtc_tc c) == length t1s
- let tyInfo = rtc_info c
- csvar <- splitsCWithVariance γ' t1s t2s $ varianceTyArgs tyInfo
- csvar' <- rsplitsCWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo
- return $ cs ++ csvar ++ csvar'
-
-splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _))
- | a1 == a2
- = bsplitC γ t1 t2
-
-splitC (SubC γ t1 t2)
- = panic (Just $ getLocation γ) $ "(Another Broken Test!!!) splitc unexpected:\n" ++ traceTy t1 ++ "\n <:\n" ++ traceTy t2
-
-splitC (SubR γ o r)
- = do ts <- getTemplates
- let r1' = pruneUnsortedReft γ'' ts r1
- return $ F.subC γ' r1' r2 Nothing tag ci
- where
- γ'' = feEnv $ fenv γ
- γ' = feBinds $ fenv γ
- r1 = F.RR F.boolSort rr
- r2 = F.RR F.boolSort $ F.Reft (vv, F.EVar vv)
- vv = "vvRec"
- ci = Ci src err (cgVar γ)
- err = Just $ ErrAssType src o (text $ show o ++ "type error") g (rHole rr)
- rr = F.toReft r
- tag = getTag γ
- src = getLocation γ
- g = reLocal $ renv γ
-
-traceTy :: SpecType -> String
-traceTy (RVar v _) = parens ("RVar " ++ showpp v)
-traceTy (RApp c ts _ _) = parens ("RApp " ++ showpp c ++ unwords (traceTy <$> ts))
-traceTy (RAllP _ t) = parens ("RAllP " ++ traceTy t)
-traceTy (RAllT _ t _) = parens ("RAllT " ++ traceTy t)
-traceTy (RImpF _ t t' _) = parens ("RImpF " ++ parens (traceTy t) ++ parens (traceTy t'))
-traceTy (RFun _ t t' _) = parens ("RFun " ++ parens (traceTy t) ++ parens (traceTy t'))
-traceTy (RAllE _ tx t) = parens ("RAllE " ++ parens (traceTy tx) ++ parens (traceTy t))
-traceTy (REx _ tx t) = parens ("REx " ++ parens (traceTy tx) ++ parens (traceTy t))
-traceTy (RExprArg _) = "RExprArg"
-traceTy (RAppTy t t' _) = parens ("RAppTy " ++ parens (traceTy t) ++ parens (traceTy t'))
-traceTy (RHole _) = "rHole"
-traceTy (RRTy _ _ _ t) = parens ("RRTy " ++ traceTy t)
-
-parens :: String -> String
-parens s = "(" ++ s ++ ")"
-
-rHole :: F.Reft -> SpecType
-rHole = RHole . uTop
-
-
-splitsCWithVariance :: CGEnv
- -> [SpecType]
- -> [SpecType]
- -> [Variance]
- -> CG [FixSubC]
-splitsCWithVariance γ t1s t2s variants
- = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> (splitC (SubC γ s1 s2))) t1 t2 v) (zip3 t1s t2s variants)
-
-rsplitsCWithVariance :: Bool
- -> CGEnv
- -> [SpecProp]
- -> [SpecProp]
- -> [Variance]
- -> CG [FixSubC]
-rsplitsCWithVariance False _ _ _ _
- = return []
-
-rsplitsCWithVariance _ γ t1s t2s variants
- = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitC γ) t1 t2 v) (zip3 t1s t2s variants)
-
-bsplitC :: CGEnv
- -> SpecType
- -> SpecType
- -> CG [F.SubC Cinfo]
-bsplitC γ t1 t2 = do
- temp <- getTemplates
- isHO <- allowHO <$> get
- t1' <- addLhsInv γ <$> refreshVV t1
- return $ bsplitC' γ t1' t2 temp isHO
-
-addLhsInv :: CGEnv -> SpecType -> SpecType
-addLhsInv γ t = addRTyConInv (invs γ) t `strengthen` r
- where
- r = (mempty :: UReft F.Reft) { ur_reft = F.Reft (F.dummySymbol, p) }
- p = constraintToLogic rE' (lcs γ)
- rE' = insertREnv v t (renv γ)
- v = rTypeValueVar t
-
-
-bsplitC' :: CGEnv -> SpecType -> SpecType -> F.Templates -> Bool -> [F.SubC Cinfo]
-bsplitC' γ t1 t2 tem isHO
- | isHO
- = F.subC γ' r1' r2' Nothing tag ci
- | F.isFunctionSortedReft r1' && F.isNonTrivial r2'
- = F.subC γ' (r1' {F.sr_reft = mempty}) r2' Nothing tag ci
- | F.isNonTrivial r2'
- = F.subC γ' r1' r2' Nothing tag ci
- | otherwise
- = []
- where
- γ' = feBinds $ fenv γ
- r1' = rTypeSortedReft' γ tem t1
- r2' = rTypeSortedReft' γ tem t2
- ci = Ci src err (cgVar γ)
- tag = getTag γ
- -- err = Just $ ErrSubType src "subtype" g t1 t2
- err = Just $ fromMaybe (ErrSubType src (text "subtype") g t1 t2) (cerr γ)
- src = getLocation γ
- g = reLocal $ renv γ
-
-unifyVV :: SpecType -> SpecType -> CG (SpecType, SpecType)
-unifyVV t1@(RApp _ _ _ _) t2@(RApp _ _ _ _)
- = do vv <- (F.vv . Just) <$> fresh
- return $ (shiftVV t1 vv, (shiftVV t2 vv) )
-
-unifyVV _ _
- = panic Nothing $ "Constraint.Generate.unifyVV called on invalid inputs"
-
-rsplitC :: CGEnv
- -> SpecProp
- -> SpecProp
- -> CG [FixSubC]
-rsplitC _ _ (RProp _ (RHole _))
- = panic Nothing "RefTypes.rsplitC on RProp _ (RHole _)"
-
-rsplitC _ (RProp _ (RHole _)) _
- = panic Nothing "RefTypes.rsplitC on RProp _ (RHole _)"
-
-rsplitC γ (RProp s1 r1) (RProp s2 r2)
- = do γ' <- foldM (+=) γ [("rsplitC1", x, ofRSort s) | (x, s) <- s2]
- splitC (SubC γ' (F.subst su r1) r2)
- where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2]
-
-
---------------------------------------------------------------------------------
--- | Reftypes from F.Fixpoint Expressions --------------------------------------
---------------------------------------------------------------------------------
-forallExprRefType :: CGEnv -> SpecType -> SpecType
-forallExprRefType γ t = t `strengthen` (uTop r')
- where
- r' = fromMaybe mempty $ forallExprReft γ r
- r = F.sr_reft $ rTypeSortedReft (emb γ) t
-
-forallExprReft :: CGEnv -> F.Reft -> Maybe F.Reft
-forallExprReft γ r =
- do e <- F.isSingletonReft r
- forallExprReft_ γ $ F.splitEApp e
-
-forallExprReft_ :: CGEnv -> (F.Expr, [F.Expr]) -> Maybe F.Reft
-forallExprReft_ γ (F.EVar x, [])
- = case forallExprReftLookup γ x of
- Just (_,_,_,t) -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t
- Nothing -> Nothing
-
-forallExprReft_ γ (F.EVar f, es)
- = case forallExprReftLookup γ f of
- Just (xs,_,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in
- Just $ F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t
- Nothing -> Nothing
-
-forallExprReft_ _ _
- = Nothing
-
--- forallExprReftLookup :: CGEnv -> F.Symbol -> Int
-forallExprReftLookup :: CGEnv
- -> F.Symbol
- -> Maybe ([F.Symbol], [SpecType], [RReft], SpecType)
-forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ)
- where
- snap = mapFourth4 ignoreOblig . (\(_,(a,b,c),t)->(a,b,c,t)) . bkArrow . thd3 . bkUniv . lookup
- lookup z = fromMaybe (panicUnbound γ z) (γ ?= F.symbol z)
-
-
---------------------------------------------------------------------------------
-getTag :: CGEnv -> F.Tag
---------------------------------------------------------------------------------
-getTag γ = maybe Tg.defaultTag (`Tg.getTag` tgEnv γ) (tgKey γ)
-
-
---------------------------------------------------------------------------------
--- | Constraint Generation Panic -----------------------------------------------
---------------------------------------------------------------------------------
-panicUnbound :: (PPrint x) => CGEnv -> x -> a
-panicUnbound γ x = Ex.throw $ (ErrUnbound (getLocation γ) (F.pprint x) :: Error)
diff --git a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs
+++ /dev/null
@@ -1,287 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-module Language.Haskell.Liquid.Constraint.ToFixpoint
- ( cgInfoFInfo
- , fixConfig
- , refinementEQs
- , canRewrite
- ) where
-
-import Prelude hiding (error)
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import qualified Language.Fixpoint.Types.Config as FC
-import System.Console.CmdArgs.Default (def)
-import qualified Language.Fixpoint.Types as F
-import Language.Fixpoint.Solver.Rewrite (unify)
-import Language.Haskell.Liquid.Constraint.Types
-import qualified Language.Haskell.Liquid.Types.RefType as RT
-import Language.Haskell.Liquid.Constraint.Qualifier
-import Control.Monad (guard)
-import qualified Data.Maybe as Mb
-
--- AT: Move to own module?
--- imports for AxiomEnv
-import qualified Language.Haskell.Liquid.UX.Config as Config
-import Language.Haskell.Liquid.UX.DiffCheck (coreDeps, dependsOn)
-import qualified Language.Haskell.Liquid.GHC.Misc as GM -- (simplesymbol)
-import qualified Data.List as L
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
--- import Language.Fixpoint.Misc
-import qualified Language.Haskell.Liquid.Misc as Misc
-import Var
-import TyCon (TyCon)
-
-import Language.Haskell.Liquid.Types hiding ( binds )
-
-fixConfig :: FilePath -> Config -> FC.Config
-fixConfig tgt cfg = def
- { FC.solver = Mb.fromJust (smtsolver cfg)
- , FC.linear = linear cfg
- , FC.eliminate = eliminate cfg
- , FC.nonLinCuts = not (higherOrderFlag cfg) -- eliminate cfg /= FC.All
- , FC.save = saveQuery cfg
- , FC.srcFile = tgt
- , FC.cores = cores cfg
- , FC.minPartSize = minPartSize cfg
- , FC.maxPartSize = maxPartSize cfg
- , FC.elimStats = elimStats cfg
- , FC.elimBound = elimBound cfg
- , FC.allowHO = higherOrderFlag cfg
- , FC.allowHOqs = higherorderqs cfg
- , FC.smtTimeout = smtTimeout cfg
- , FC.stringTheory = stringTheory cfg
- , FC.gradual = gradual cfg
- , FC.ginteractive = ginteractive cfg
- , FC.noslice = noslice cfg
- , FC.rewriteAxioms = Config.allowPLE cfg
- , FC.etaElim = not (exactDC cfg) && extensionality cfg -- SEE: https://github.com/ucsd-progsys/liquidhaskell/issues/1601
- , FC.extensionality = extensionality cfg
- , FC.oldPLE = oldPLE cfg
- , FC.maxRWOrderingConstraints = maxRWOrderingConstraints cfg
- , FC.rwTerminationCheck = rwTerminationCheck cfg
- }
-
-
-cgInfoFInfo :: TargetInfo -> CGInfo -> IO (F.FInfo Cinfo)
-cgInfoFInfo info cgi = return (targetFInfo info cgi)
-
-targetFInfo :: TargetInfo -> CGInfo -> F.FInfo Cinfo
-targetFInfo info cgi = mappend (mempty { F.ae = ax }) fi
- where
- fi = F.fi cs ws bs ls consts ks qs bi aHO aHOqs es mempty adts ebs
- cs = fixCs cgi
- ws = fixWfs cgi
- bs = binds cgi
- ebs = ebinds cgi
- ls = fEnv cgi
- consts = cgConsts cgi
- ks = kuts cgi
- adts = cgADTs cgi
- qs = giQuals info (fEnv cgi)
- bi = (\x -> Ci x Nothing Nothing) <$> bindSpans cgi
- aHO = allowHO cgi
- aHOqs = higherOrderFlag info
- es = [] -- makeAxioms info
- ax = makeAxiomEnvironment info (dataConTys cgi) (F.cm fi)
- -- msg = show . map F.symbol . M.keys . tyConInfo
-
-makeAxiomEnvironment :: TargetInfo -> [(Var, SpecType)] -> M.HashMap F.SubcId (F.SubC Cinfo) -> F.AxiomEnv
-makeAxiomEnvironment info xts fcs
- = F.AEnv eqs
- (concatMap makeSimplify xts)
- (doExpand sp cfg <$> fcs)
- (makeRewrites info <$> fcs)
- where
- eqs = if (oldPLE cfg)
- then (makeEquations sp ++ map (uncurry $ specTypeEq emb) xts)
- else axioms
- emb = gsTcEmbeds (gsName sp)
- cfg = getConfig info
- sp = giSpec info
- axioms = gsMyAxioms refl ++ gsImpAxioms refl
- refl = gsRefl sp
-
-
-makeRewrites :: TargetInfo -> F.SubC Cinfo -> [F.AutoRewrite]
-makeRewrites info sub = concatMap (makeRewriteOne tce) $ filter ((`S.member` rws) . fst) sigs
- where
- tce = gsTcEmbeds (gsName spec)
- spec = giSpec info
- sig = gsSig spec
- sigs = gsTySigs sig ++ gsAsmSigs sig
- isGlobalRw = Mb.maybe False (`elem` globalRws) (subVar sub)
-
- rws =
- if isGlobalRw
- then S.empty
- else S.difference
- (S.union localRws globalRws)
- (Mb.maybe S.empty forbiddenRWs (subVar sub))
-
- allDeps = coreDeps $ giCbs $ giSrc info
- forbiddenRWs sv =
- S.insert sv $ dependsOn allDeps [sv]
-
- localRws = Mb.fromMaybe S.empty $ do
- var <- subVar sub
- usable <- M.lookup var $ gsRewritesWith $ gsRefl spec
- return $ S.fromList usable
- globalRws = S.map val $ gsRewrites $ gsRefl spec
-
-canRewrite :: S.HashSet F.Symbol -> F.Expr -> F.Expr -> Bool
-canRewrite freeVars from to = noFreeSyms && doesNotDiverge
- where
- fromSyms = S.intersection freeVars (S.fromList $ F.syms from)
- toSyms = S.intersection freeVars (S.fromList $ F.syms to)
- noFreeSyms = S.null $ S.difference toSyms fromSyms
- doesNotDiverge = Mb.isNothing (unify (S.toList freeVars) from to)
- || Mb.isJust (unify (S.toList freeVars) to from)
-
-refinementEQs :: LocSpecType -> [(F.Expr, F.Expr)]
-refinementEQs t =
- case stripRTypeBase tres of
- Just r ->
- [ (lhs, rhs) | (F.EEq lhs rhs) <- F.splitPAnd $ F.reftPred (F.toReft r) ]
- Nothing ->
- []
- where
- tres = ty_res tRep
- tRep = toRTypeRep $ val t
-
-makeRewriteOne :: (F.TCEmb TyCon) -> (Var,LocSpecType) -> [F.AutoRewrite]
-makeRewriteOne tce (_,t)
- = [rw | (lhs, rhs) <- refinementEQs t , rw <- rewrites lhs rhs ]
- where
-
- rewrites :: F.Expr -> F.Expr -> [F.AutoRewrite]
- rewrites lhs rhs =
- (guard (canRewrite freeVars lhs rhs) >> [F.AutoRewrite xs lhs rhs])
- ++ (guard (canRewrite freeVars rhs lhs) >> [F.AutoRewrite xs rhs lhs])
-
- freeVars = S.fromList (ty_binds tRep)
-
- xs = do
- (sym, arg) <- zip (ty_binds tRep) (ty_args tRep)
- let e = maybe F.PTrue (F.reftPred . F.toReft) (stripRTypeBase arg)
- return $ F.RR (rTypeSort tce arg) (F.Reft (sym, e))
-
- tRep = toRTypeRep $ val t
-
-_isClassOrDict :: Id -> Bool
-_isClassOrDict x = F.tracepp ("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))
- where
- msg = "hasClassArg: " ++ showpp (x, t:ts)
- (ts, t) = Ghc.splitFunTys . snd . Ghc.splitForAllTys . Ghc.varType $ x
-
-
-doExpand :: TargetSpec -> Config -> F.SubC Cinfo -> Bool
-doExpand sp cfg sub = Config.allowGlobalPLE cfg
- || (Config.allowLocalPLE cfg && maybe False (isPLEVar sp) (subVar sub))
-
--- [TODO:missing-sorts] data-constructors often have unelaboratable 'define' so either
--- 1. Make `elaborate` robust so it doesn't crash and returns maybe or
--- 2. Make the `ctor` well-sorted or
--- 3. Don't create `define` for the ctor.
--- Unfortunately 3 breaks a bunch of tests...
-
-specTypeEq :: F.TCEmb TyCon -> Var -> SpecType -> F.Equation
-specTypeEq emb f t = F.mkEquation (F.symbol f) xts body tOut
- where
- xts = Misc.safeZipWithError "specTypeEq" xs (RT.rTypeSort emb <$> ts)
- body = specTypeToResultRef bExp t
- tOut = RT.rTypeSort emb (ty_res tRep)
- tRep = toRTypeRep t
- xs = ty_binds tRep
- ts = ty_args tRep
- bExp = F.eApps (F.eVar f) (F.EVar <$> xs)
-
-makeSimplify :: (Var, SpecType) -> [F.Rewrite]
-makeSimplify (x, t)
- | not (GM.isDataConId x)
- = []
- | otherwise
- = go $ specTypeToResultRef (F.eApps (F.EVar $ F.symbol x) (F.EVar <$> ty_binds (toRTypeRep t))) t
- where
- go (F.PAnd es) = concatMap go es
-
- go (F.PAtom eq (F.EApp (F.EVar f) dc) bd)
- | eq `elem` [F.Eq, F.Ueq]
- , (F.EVar dc, xs) <- F.splitEApp dc
- , dc == F.symbol x
- , all isEVar xs
- = [F.SMeasure f dc (fromEVar <$> xs) bd]
-
- go (F.PIff (F.EApp (F.EVar f) dc) bd)
- | (F.EVar dc, xs) <- F.splitEApp dc
- , dc == F.symbol x
- , all isEVar xs
- = [F.SMeasure f dc (fromEVar <$> xs) bd]
-
- go _ = []
-
- isEVar (F.EVar _) = True
- isEVar _ = False
-
- fromEVar (F.EVar x) = x
- fromEVar _ = impossible Nothing "makeSimplify.fromEVar"
-
-makeEquations :: TargetSpec -> [F.Equation]
-makeEquations sp = [ F.mkEquation f xts (equationBody (F.EVar f) xArgs e mbT) t
- | F.Equ f xts e t _ <- axioms
- , let xArgs = F.EVar . fst <$> xts
- , let mbT = if null xArgs then Nothing else M.lookup f sigs
- ]
- where
- axioms = gsMyAxioms refl ++ gsImpAxioms refl
- refl = gsRefl sp
- sigs = M.fromList [ (GM.simplesymbol v, t) | (v, t) <- gsTySigs (gsSig sp) ]
-
-equationBody :: F.Expr -> [F.Expr] -> F.Expr -> Maybe LocSpecType -> F.Expr
-equationBody f xArgs e mbT
- | Just t <- mbT = F.pAnd [eBody, rBody t]
- | otherwise = eBody
- where
- eBody = F.PAtom F.Eq (F.eApps f xArgs) e
- rBody t = specTypeToLogic xArgs (F.eApps f xArgs) (val t)
-
--- NV Move this to types?
--- sound but imprecise approximation of a type in the logic
-specTypeToLogic :: [F.Expr] -> F.Expr -> SpecType -> F.Expr
-specTypeToLogic es e t
- | ok = F.subst su (F.PImp (F.pAnd args) res)
- | otherwise = F.PTrue
- where
- res = specTypeToResultRef e t
- args = zipWith mkExpr (mkReft <$> ts) es
- mkReft t = F.toReft $ Mb.fromMaybe mempty (stripRTypeBase t)
- mkExpr (F.Reft (v, ev)) e = F.subst1 ev (v, e)
-
-
- ok = okLen && okClass && okArgs
- okLen = length xs == length xs
- okClass = all (F.isTauto . snd) cls
- okArgs = all okArg ts
-
- okArg (RVar _ _) = True
- okArg t@(RApp _ _ _ _) = F.isTauto (t{rt_reft = mempty})
- okArg _ = False
-
-
- su = F.mkSubst $ zip xs es
- (cls, nocls) = L.partition (isClassType.snd) $ zip (ty_binds trep) (ty_args trep)
- :: ([(F.Symbol, SpecType)], [(F.Symbol, SpecType)])
- (xs, ts) = unzip nocls :: ([F.Symbol], [SpecType])
-
- trep = toRTypeRep t
-
-
-specTypeToResultRef :: F.Expr -> SpecType -> F.Expr
-specTypeToResultRef e t
- = mkExpr $ F.toReft $ Mb.fromMaybe mempty (stripRTypeBase $ ty_res trep)
- where
- mkExpr (F.Reft (v, ev)) = F.subst1 ev (v, e)
- trep = toRTypeRep t
diff --git a/src/Language/Haskell/Liquid/Constraint/Types.hs b/src/Language/Haskell/Liquid/Constraint/Types.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/Constraint/Types.hs
+++ /dev/null
@@ -1,442 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-
-module Language.Haskell.Liquid.Constraint.Types
- ( -- * Constraint Generation Monad
- CG
-
- -- * Constraint information
- , CGInfo (..)
-
- -- * Constraint Generation Environment
- , CGEnv (..)
-
- -- * Logical constraints (FIXME: related to bounds?)
- , LConstraint (..)
-
- -- * Fixpoint environment
- , FEnv (..)
- , initFEnv
- , insertsFEnv
- -- , removeFEnv
-
- -- * Hole Environment
- , HEnv
- , fromListHEnv
- , elemHEnv
-
- -- * Subtyping Constraints
- , SubC (..)
- , FixSubC
-
- , subVar
-
- -- * Well-formedness Constraints
- , WfC (..)
- , FixWfC
-
- -- * Invariants
- , RTyConInv
- , mkRTyConInv
- , addRTyConInv
- , addRInv
-
- -- * Aliases?
- , RTyConIAl
- , mkRTyConIAl
-
- , removeInvariant, restoreInvariant, makeRecInvariants
-
- , getTemplates
- ) where
-
-import Prelude hiding (error)
-import CoreSyn
-import Type (TyThing( AnId ))
-import Var
-import SrcLoc
-import Unify (tcUnifyTy)
-import qualified TyCon as TC
-import qualified DataCon as DC
-import Text.PrettyPrint.HughesPJ hiding ((<>))
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-import qualified Data.List as L
-import Control.DeepSeq
-import Data.Maybe (catMaybes, isJust)
-import Control.Monad.State
-
-import Language.Haskell.Liquid.GHC.SpanStack
-import Language.Haskell.Liquid.Misc (thrd3)
-import Language.Haskell.Liquid.WiredIn (wiredSortedSyms)
-import qualified Language.Fixpoint.Types as F
-import Language.Fixpoint.Misc
-
-import qualified Language.Haskell.Liquid.UX.CTags as Tg
-
-import Language.Haskell.Liquid.Types hiding (binds)
-
-type CG = State CGInfo
-
-data CGEnv = CGE
- { cgLoc :: !SpanStack -- ^ Location in original source file
- , renv :: !REnv -- ^ SpecTypes for Bindings in scope
- , syenv :: !(F.SEnv Var) -- ^ Map from free Symbols (e.g. datacons) to Var
- , denv :: !RDEnv -- ^ Dictionary Environment
- , litEnv :: !(F.SEnv F.Sort) -- ^ Global literals
- , constEnv :: !(F.SEnv F.Sort) -- ^ Distinct literals
- , fenv :: !FEnv -- ^ Fixpoint Environment
- , recs :: !(S.HashSet Var) -- ^ recursive defs being processed (for annotations)
- , invs :: !RTyConInv -- ^ Datatype invariants
- , rinvs :: !RTyConInv -- ^ Datatype recursive invariants: ignored in the base case assumed in rec call
- , ial :: !RTyConIAl -- ^ Datatype checkable invariants
- , grtys :: !REnv -- ^ Top-level variables with (assert)-guarantees to verify
- , assms :: !REnv -- ^ Top-level variables with assumed types
- , intys :: !REnv -- ^ Top-level variables with auto generated internal types
- , emb :: F.TCEmb TC.TyCon -- ^ How to embed GHC Tycons into fixpoint sorts
- , tgEnv :: !Tg.TagEnv -- ^ Map from top-level binders to fixpoint tag
- , tgKey :: !(Maybe Tg.TagKey) -- ^ Current top-level binder
- , trec :: !(Maybe (M.HashMap F.Symbol SpecType)) -- ^ Type of recursive function with decreasing constraints
- , lcb :: !(M.HashMap F.Symbol CoreExpr) -- ^ Let binding that have not been checked (c.f. LAZYVARs)
- , forallcb :: !(M.HashMap Var F.Expr) -- ^ Polymorhic let bindings
- , holes :: !HEnv -- ^ Types with holes, will need refreshing
- , lcs :: !LConstraint -- ^ Logical Constraints
- , cerr :: !(Maybe (TError SpecType)) -- ^ error that should be reported at the user
- , cgInfo :: !TargetInfo -- ^ top-level TargetInfo
- , cgVar :: !(Maybe Var) -- ^ top level function being checked
- } -- deriving (Data, Typeable)
-
-instance HasConfig CGEnv where
- getConfig = getConfig . cgInfo
-
-data LConstraint = LC [[(F.Symbol, SpecType)]]
-
-instance Monoid LConstraint where
- mempty = LC []
- mappend = (<>)
-
-instance Semigroup LConstraint where
- LC cs1 <> LC cs2 = LC (cs1 ++ cs2)
-
-instance PPrint CGEnv where
- pprintTidy k = pprintTidy k . renv
-
-instance Show CGEnv where
- show = showpp
-
---------------------------------------------------------------------------------
--- | Subtyping Constraints -----------------------------------------------------
---------------------------------------------------------------------------------
-
--- RJ: what is the difference between these two?
-
-data SubC = SubC { senv :: !CGEnv
- , lhs :: !SpecType
- , rhs :: !SpecType
- }
- | SubR { senv :: !CGEnv
- , oblig :: !Oblig
- , ref :: !RReft
- }
-
-data WfC = WfC !CGEnv !SpecType
- -- deriving (Data, Typeable)
-
-type FixSubC = F.SubC Cinfo
-type FixWfC = F.WfC Cinfo
-
-
-subVar :: FixSubC -> Maybe Var
-subVar = ci_var . F.sinfo
-
-instance PPrint SubC where
- pprintTidy k c@(SubC {}) = pprintTidy k (senv c)
- $+$ ("||-" <+> vcat [ pprintTidy k (lhs c)
- , "<:"
- , pprintTidy k (rhs c) ] )
- pprintTidy k c@(SubR {}) = pprintTidy k (senv c)
- $+$ ("||-" <+> vcat [ pprintTidy k (ref c)
- , parens (pprintTidy k (oblig c))])
-
-
-instance PPrint WfC where
- pprintTidy k (WfC _ r) = {- pprintTidy k w <> text -} "<...> |-" <+> pprintTidy k r
-
-
---------------------------------------------------------------------------------
--- | Generation: Types ---------------------------------------------------------
---------------------------------------------------------------------------------
-data CGInfo = CGInfo
- { fEnv :: !(F.SEnv F.Sort) -- ^ top-level fixpoint env
- , hsCs :: ![SubC] -- ^ subtyping constraints over RType
- , hsWfs :: ![WfC] -- ^ wellformedness constraints over RType
- , fixCs :: ![FixSubC] -- ^ subtyping over Sort (post-splitting)
- , fixWfs :: ![FixWfC] -- ^ wellformedness constraints over Sort (post-splitting)
- , freshIndex :: !Integer -- ^ counter for generating fresh KVars
- , binds :: !F.BindEnv -- ^ set of environment binders
- , ebinds :: ![F.BindId] -- ^ existentials
- , annotMap :: !(AnnInfo (Annot SpecType)) -- ^ source-position annotation map
- , holesMap :: !(M.HashMap Var (HoleInfo (CGInfo, CGEnv) SpecType)) -- ^ information for ghc hole expressions
- , tyConInfo :: !TyConMap -- ^ information about type-constructors
- , specDecr :: ![(Var, [Int])] -- ^ ^ Lexicographic order of decreasing args (DEPRECATED)
- , newTyEnv :: !(M.HashMap TC.TyCon SpecType) -- ^ Mapping of new type type constructors with their refined types.
- , termExprs :: !(M.HashMap Var [F.Located F.Expr]) -- ^ Terminating Metrics for Recursive functions
- , specLVars :: !(S.HashSet Var) -- ^ Set of variables to ignore for termination checking
- , specLazy :: !(S.HashSet Var) -- ^ "Lazy binders", skip termination checking
- , specTmVars :: !(S.HashSet Var) -- ^ Binders that FAILED struct termination check that MUST be checked
- , autoSize :: !(S.HashSet TC.TyCon) -- ^ ? FIX THIS
- , tyConEmbed :: !(F.TCEmb TC.TyCon) -- ^ primitive Sorts into which TyCons should be embedded
- , kuts :: !F.Kuts -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)
- , kvPacks :: ![S.HashSet F.KVar] -- ^ Fixpoint "packs" of correlated kvars
- , cgLits :: !(F.SEnv F.Sort) -- ^ Global symbols in the refinement logic
- , cgConsts :: !(F.SEnv F.Sort) -- ^ Distinct constant symbols in the refinement logic
- , cgADTs :: ![F.DataDecl] -- ^ ADTs extracted from Haskell 'data' definitions
- , tcheck :: !Bool -- ^ Check Termination (?)
- , pruneRefs :: !Bool -- ^ prune unsorted refinements
- , logErrors :: ![Error] -- ^ Errors during constraint generation
- , kvProf :: !KVProf -- ^ Profiling distribution of KVars
- , recCount :: !Int -- ^ number of recursive functions seen (for benchmarks)
- , bindSpans :: M.HashMap F.BindId SrcSpan -- ^ Source Span associated with Fixpoint Binder
- , allowHO :: !Bool
- , ghcI :: !TargetInfo
- , dataConTys :: ![(Var, SpecType)] -- ^ Refined Types of Data Constructors
- , unsorted :: !F.Templates -- ^ Potentially unsorted expressions
- }
-
-
-getTemplates :: CG F.Templates
-getTemplates = do
- fg <- pruneRefs <$> get
- ts <- unsorted <$> get
- return $ if fg then F.anything else ts
-
-
-instance PPrint CGInfo where
- pprintTidy = pprCGInfo
-
-pprCGInfo :: F.Tidy -> CGInfo -> Doc
-pprCGInfo _k _cgi
- = "*********** Constraint Information (omitted) *************"
- -- -$$ (text "*********** Haskell SubConstraints ***********")
- -- -$$ (pprintLongList $ hsCs cgi)
- -- -$$ (text "*********** Haskell WFConstraints ************")
- -- -$$ (pprintLongList $ hsWfs cgi)
- -- -$$ (text "*********** Fixpoint SubConstraints **********")
- -- -$$ (F.toFix $ fixCs cgi)
- -- -$$ (text "*********** Fixpoint WFConstraints ************")
- -- -$$ (F.toFix $ fixWfs cgi)
- -- -$$ (text "*********** Fixpoint Kut Variables ************")
- -- -$$ (F.toFix $ kuts cgi)
- -- -$$ "*********** Literals in Source ************"
- -- -$$ F.pprint (cgLits _cgi)
- -- -$$ (text "*********** KVar Distribution *****************")
- -- -$$ (pprint $ kvProf cgi)
- -- -$$ (text "Recursive binders:" <+> pprint (recCount cgi))
-
-
---------------------------------------------------------------------------------
--- | Helper Types: HEnv --------------------------------------------------------
---------------------------------------------------------------------------------
-
-newtype HEnv = HEnv (S.HashSet F.Symbol)
-
-fromListHEnv :: [F.Symbol] -> HEnv
-fromListHEnv = HEnv . S.fromList
-
-elemHEnv :: F.Symbol -> HEnv -> Bool
-elemHEnv x (HEnv s) = x `S.member` s
-
---------------------------------------------------------------------------------
--- | Helper Types: Invariants --------------------------------------------------
---------------------------------------------------------------------------------
-data RInv = RInv { _rinv_args :: [RSort] -- empty list means that the invariant is generic
- -- for all type arguments
- , _rinv_type :: SpecType
- , _rinv_name :: Maybe Var
- } deriving Show
-
-type RTyConInv = M.HashMap RTyCon [RInv]
-type RTyConIAl = M.HashMap RTyCon [RInv]
-
---------------------------------------------------------------------------------
-mkRTyConInv :: [(Maybe Var, F.Located SpecType)] -> RTyConInv
---------------------------------------------------------------------------------
-mkRTyConInv ts = group [ (c, RInv (go ts) t v) | (v, t@(RApp c ts _ _)) <- strip <$> ts]
- where
- strip = mapSnd (thrd3 . bkUniv . val)
- go ts | generic (toRSort <$> ts) = []
- | otherwise = toRSort <$> ts
-
- generic ts = let ts' = L.nub ts in
- all isRVar ts' && length ts' == length ts
-
-mkRTyConIAl :: [(a, F.Located SpecType)] -> RTyConInv
-mkRTyConIAl = mkRTyConInv . fmap ((Nothing,) . snd)
-
-addRTyConInv :: RTyConInv -> SpecType -> SpecType
-addRTyConInv m t
- = case lookupRInv t m of
- Nothing -> t
- Just ts -> L.foldl' conjoinInvariantShift t ts
-
-lookupRInv :: SpecType -> RTyConInv -> Maybe [SpecType]
-lookupRInv (RApp c ts _ _) m
- = case M.lookup c m of
- Nothing -> Nothing
- Just invs -> Just (catMaybes $ goodInvs ts <$> invs)
-lookupRInv _ _
- = Nothing
-
-goodInvs :: [SpecType] -> RInv -> Maybe SpecType
-goodInvs _ (RInv [] t _)
- = Just t
-goodInvs ts (RInv ts' t _)
- | and (zipWith unifiable ts' (toRSort <$> ts))
- = Just t
- | otherwise
- = Nothing
-
-
-unifiable :: RSort -> RSort -> Bool
-unifiable t1 t2 = isJust $ tcUnifyTy (toType t1) (toType t2)
-
-addRInv :: RTyConInv -> (Var, SpecType) -> (Var, SpecType)
-addRInv m (x, t)
- | x `elem` ids , Just invs <- lookupRInv (res t) m
- = (x, addInvCond t (mconcat $ catMaybes (stripRTypeBase <$> invs)))
- | otherwise
- = (x, t)
- where
- ids = [id | tc <- M.keys m
- , dc <- TC.tyConDataCons $ rtc_tc tc
- , AnId id <- DC.dataConImplicitTyThings dc]
- res = ty_res . toRTypeRep
-
-conjoinInvariantShift :: SpecType -> SpecType -> SpecType
-conjoinInvariantShift t1 t2
- = conjoinInvariant t1 (shiftVV t2 (rTypeValueVar t1))
-
-conjoinInvariant :: SpecType -> SpecType -> SpecType
-conjoinInvariant (RApp c ts rs r) (RApp ic its _ ir)
- | c == ic && length ts == length its
- = RApp c (zipWith conjoinInvariantShift ts its) rs (r `F.meet` ir)
-
-conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir)
- = t { rt_reft = r `F.meet` ir }
-
-conjoinInvariant t@(RVar _ r) (RVar _ ir)
- = t { rt_reft = r `F.meet` ir }
-
-conjoinInvariant t _
- = t
-
-removeInvariant :: CGEnv -> CoreBind -> (CGEnv, RTyConInv)
-removeInvariant γ cbs
- = (γ { invs = M.map (filter f) (invs γ)
- , rinvs = M.map (filter (not . f)) (invs γ)}
- , invs γ)
- where
- f i | Just v <- _rinv_name i, v `elem` binds cbs
- = False
- | otherwise
- = True
- binds (NonRec x _) = [x]
- binds (Rec xes) = fst $ unzip xes
-
-restoreInvariant :: CGEnv -> RTyConInv -> CGEnv
-restoreInvariant γ is = γ {invs = is}
-
-makeRecInvariants :: CGEnv -> [Var] -> CGEnv
-makeRecInvariants γ [x] = γ {invs = M.unionWith (++) (invs γ) is}
- where
- is = M.map (map f . filter (isJust . (varType x `tcUnifyTy`) . toType . _rinv_type)) (rinvs γ)
- f i = i{_rinv_type = guard $ _rinv_type i}
-
- guard (RApp c ts rs r)
- | Just f <- szFun <$> sizeFunction (rtc_info c)
- = RApp c ts rs (MkUReft (ref f $ F.toReft r) mempty)
- | otherwise
- = RApp c ts rs mempty
- guard t
- = t
-
- ref f (F.Reft(v, rr))
- = F.Reft (v, F.PImp (F.PAtom F.Lt (f v) (f $ F.symbol x)) rr)
-
-makeRecInvariants γ _ = γ
-
---------------------------------------------------------------------------------
--- | Fixpoint Environment ------------------------------------------------------
---------------------------------------------------------------------------------
-
-data FEnv = FE
- { feBinds :: !F.IBindEnv -- ^ Integer Keys for Fixpoint Environment
- , feEnv :: !(F.SEnv F.Sort) -- ^ Fixpoint Environment
- , feIdEnv :: !(F.SEnv F.BindId) -- ^ Map from Symbol to current BindId
- }
-
-insertFEnv :: FEnv -> ((F.Symbol, F.Sort), F.BindId) -> FEnv
-insertFEnv (FE benv env ienv) ((x, t), i)
- = FE (F.insertsIBindEnv [i] benv)
- (F.insertSEnv x t env)
- (F.insertSEnv x i ienv)
-
-insertsFEnv :: FEnv -> [((F.Symbol, F.Sort), F.BindId)] -> FEnv
-insertsFEnv = L.foldl' insertFEnv
-
-initFEnv :: [(F.Symbol, F.Sort)] -> FEnv
-initFEnv xts = FE benv0 env0 ienv0
- where
- benv0 = F.emptyIBindEnv
- env0 = F.fromListSEnv (wiredSortedSyms ++ xts)
- ienv0 = F.emptySEnv
-
---------------------------------------------------------------------------------
--- | Forcing Strictness --------------------------------------------------------
---------------------------------------------------------------------------------
-instance NFData RInv where
- rnf (RInv x y z) = rnf x `seq` rnf y `seq` rnf z
-
-instance NFData CGEnv where
- rnf (CGE x1 _ x3 _ x4 x5 x55 x6 x7 x8 x9 _ _ _ x10 _ _ _ _ _ _ _ _ _ _)
- = x1 `seq` {- rnf x2 `seq` -} seq x3
- `seq` rnf x5
- `seq` rnf x55
- `seq` rnf x6
- `seq` x7
- `seq` rnf x8
- `seq` rnf x9
- `seq` rnf x10
- `seq` rnf x4
-
-instance NFData FEnv where
- rnf (FE x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3
-
-instance NFData SubC where
- rnf (SubC x1 x2 x3)
- = rnf x1 `seq` rnf x2 `seq` rnf x3
- rnf (SubR x1 _ x2)
- = rnf x1 `seq` rnf x2
-
-instance NFData WfC where
- rnf (WfC x1 x2)
- = rnf x1 `seq` rnf x2
-
-instance NFData CGInfo where
- rnf x = ({-# SCC "CGIrnf1" #-} rnf (hsCs x)) `seq`
- ({-# SCC "CGIrnf2" #-} rnf (hsWfs x)) `seq`
- ({-# SCC "CGIrnf3" #-} rnf (fixCs x)) `seq`
- ({-# SCC "CGIrnf4" #-} rnf (fixWfs x)) `seq`
- ({-# SCC "CGIrnf6" #-} rnf (freshIndex x)) `seq`
- ({-# SCC "CGIrnf7" #-} rnf (binds x)) `seq`
- ({-# SCC "CGIrnf8" #-} rnf (annotMap x)) `seq`
- ({-# SCC "CGIrnf10" #-} rnf (kuts x)) `seq`
- ({-# SCC "CGIrnf10" #-} rnf (kvPacks x)) `seq`
- ({-# SCC "CGIrnf10" #-} rnf (cgLits x)) `seq`
- ({-# SCC "CGIrnf10" #-} rnf (cgConsts x)) `seq`
- ({-# SCC "CGIrnf10" #-} rnf (kvProf x))
diff --git a/src/Language/Haskell/Liquid/GHC/API.hs b/src/Language/Haskell/Liquid/GHC/API.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/GHC/API.hs
+++ /dev/null
@@ -1,232 +0,0 @@
--- | This module re-exports a bunch of the GHC API.
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE BangPatterns #-}
-
-module Language.Haskell.Liquid.GHC.API (
- module Ghc
-
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
- , VarBndr
- , AnonArgFlag(..)
- , pattern Bndr
- , pattern FunTy
- , pattern AnonTCB
- , pattern LitString
- , pattern LitFloat
- , pattern LitDouble
- , pattern LitChar
- , ft_af, ft_arg, ft_res
- , bytesFS
- , mkFunTy
- , isEvVarType
- , isEqPrimPred
-#endif
-#endif
-
- , tyConRealArity
- , dataConExTyVars
-
- ) where
-
-import Avail as Ghc
-import GHC as Ghc hiding (Warning)
-import ConLike as Ghc
-import Var as Ghc
-import Module as Ghc
-import DataCon as Ghc
-import TysWiredIn as Ghc
-import BasicTypes as Ghc
-import CoreSyn as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase)
-import NameSet as Ghc
-import InstEnv as Ghc
-import Literal as Ghc
-import TcType as Ghc (isClassPred)
-import Class as Ghc
-import Unique as Ghc
-import RdrName as Ghc
-import SrcLoc as Ghc
-import Name as Ghc hiding (varName)
-import TysPrim as Ghc
-import HscTypes as Ghc
-import HscMain as Ghc
-import Id as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported)
-import ErrUtils as Ghc
-import DynFlags as Ghc
-
---
--- Compatibility layer for different GHC versions.
---
-
---
--- Specific imports for GHC 8.6.5
---
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
-
-import Binary
-import Data.ByteString (ByteString)
-import Data.Data (Data)
-import Outputable
-import Kind as Ghc (classifiesTypeWithValues)
-import FastString as Ghc hiding (bytesFS, LitString)
-import TyCoRep as Ghc hiding (Type (FunTy), mkFunTy)
-import TyCon as Ghc hiding (TyConBndrVis(AnonTCB))
-import Type as Ghc hiding (typeKind, mkFunTy)
-import qualified Type as Ghc
-import qualified TyCoRep as Ty
-import qualified Literal as Lit
-import qualified TyCon as Ty
-import qualified Var as Var
-import qualified GHC.Real
-
-#endif
-#endif
-
---
--- Specific imports for GHC 8.10
---
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
-import Type as Ghc hiding (typeKind , isPredTy)
-import TyCon as Ghc
-import TyCoRep as Ghc
-import FastString as Ghc
-import Predicate as Ghc (isEqPred, getClassPredTys_maybe, isEvVarType, isEqPrimPred)
-import Data.Foldable (asum)
-#endif
-#endif
-
---
--- GHC-specific functions and pattern synonyms
---
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,5,0) && !MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
-
--- | The non-dependent version of 'ArgFlag'.
-
--- Appears here partly so that it's together with its friend ArgFlag,
--- but also because it is used in IfaceType, rather early in the
--- compilation chain
--- See Note [AnonArgFlag vs. ForallVisFlag]
-data AnonArgFlag
- = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow.
- -- The argument is visible in source code.
- | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow.
- -- The argument is invisible in source code.
- deriving (Eq, Ord, Data)
-
-instance Outputable AnonArgFlag where
- ppr VisArg = text "[vis]"
- ppr InvisArg = text "[invis]"
-
-instance Binary AnonArgFlag where
- put_ bh VisArg = putByte bh 0
- put_ bh InvisArg = putByte bh 1
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return VisArg
- _ -> return InvisArg
-
-bytesFS :: FastString -> ByteString
-bytesFS = fastStringToByteString
-
-mkFunTy :: AnonArgFlag -> Type -> Type -> Type
-mkFunTy _ = Ty.FunTy
-
-pattern Bndr :: var -> argf -> Var.TyVarBndr var argf
-pattern Bndr var argf <- TvBndr var argf where
- Bndr var argf = TvBndr var argf
-
-type VarBndr = TyVarBndr
-
-pattern FunTy :: AnonArgFlag -> Type -> Type -> Type
-pattern FunTy { ft_af, ft_arg, ft_res } <- ((VisArg,) -> (ft_af, Ty.FunTy ft_arg ft_res)) where
- FunTy _ft_af ft_arg ft_res = Ty.FunTy ft_arg ft_res
-
-pattern AnonTCB :: AnonArgFlag -> Ty.TyConBndrVis
-pattern AnonTCB af <- ((VisArg,) -> (af, Ty.AnonTCB)) where
- AnonTCB _af = Ty.AnonTCB
-
-pattern LitString :: ByteString -> Lit.Literal
-pattern LitString bs <- Lit.MachStr bs where
- LitString bs = Lit.MachStr bs
-
-pattern LitFloat :: GHC.Real.Ratio Integer -> Lit.Literal
-pattern LitFloat f <- Lit.MachFloat f where
- LitFloat f = Lit.MachFloat f
-
-pattern LitDouble :: GHC.Real.Ratio Integer -> Lit.Literal
-pattern LitDouble d <- Lit.MachDouble d where
- LitDouble d = Lit.MachDouble d
-
-pattern LitChar :: Char -> Lit.Literal
-pattern LitChar c <- Lit.MachChar c where
- LitChar c = Lit.MachChar c
-
--- See NOTE [tyConRealArity].
-tyConRealArity :: TyCon -> Int
-tyConRealArity = tyConArity
-
--- See NOTE [isEvVarType].
-isEvVarType :: Type -> Bool
-isEvVarType = Ghc.isPredTy
-
-isEqPrimPred :: Type -> Bool
-isEqPrimPred = Ghc.isPredTy
-
-#endif
-
-{- | [NOTE:tyConRealArity]
-
-The semantics of 'tyConArity' changed between GHC 8.6.5 and GHC 8.10, mostly due to the
-Visible Dependent Quantification (VDQ). As a result, given the following:
-
-data family EntityField record :: * -> *
-
-Calling `tyConArity` on this would yield @2@ for 8.6.5 but @1@ an 8.10, so we try to backport
-the old behaviour in 8.10 by \"looking\" at the 'Kind' of the input 'TyCon' and trying to recursively
-split the type apart with either 'splitFunTy_maybe' or 'splitForAllTy_maybe'.
-
--}
-
-{- | [NOTE:isEvVarType]
-
-For GHC < 8.10.1 'isPredTy' is effectively the same as the new 'isEvVarType', which covers the cases
-for coercion types and \"normal\" type coercions. The 8.6.5 version of 'isPredTy' had a special case to
-handle a 'TyConApp' in the case of type equality (i.e. ~ ) which was removed in the implementation
-for 8.10.1, which essentially calls 'tcIsConstraintKind' straight away.
--}
-
---
--- Support for GHC >= 8.10.0
---
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
-
--- See NOTE [tyConRealArity].
-tyConRealArity :: TyCon -> Int
-tyConRealArity tc = go 0 (tyConKind tc)
- where
- go :: Int -> Kind -> Int
- go !acc k =
- case asum [fmap snd (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of
- Nothing -> acc
- Just ks -> go (acc + 1) ks
-
-dataConExTyVars :: DataCon -> [TyVar]
-dataConExTyVars = dataConExTyCoVars
-
-#endif
-
---
--- End of compatibility shim.
---
-#endif
diff --git a/src/Language/Haskell/Liquid/GHC/GhcMonadLike.hs b/src/Language/Haskell/Liquid/GHC/GhcMonadLike.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/GHC/GhcMonadLike.hs
+++ /dev/null
@@ -1,293 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
--- | This module introduces a \"lighter\" "GhcMonad" typeclass which doesn't require an instance of
--- 'ExceptionMonad', and can therefore be used for both 'CoreM' and 'Ghc'.
---
-
-module Language.Haskell.Liquid.GHC.GhcMonadLike (
- -- * Types and type classes
- HasHscEnv
- , GhcMonadLike
- , ModuleInfo
- , TypecheckedModule(..)
-
- -- * Functions and typeclass methods
-
- , askHscEnv
- , getModuleGraph
- , getModSummary
- , lookupModSummary
- , lookupGlobalName
- , lookupName
- , modInfoLookupName
- , moduleInfoTc
- , parseModule
- , typecheckModule
- , desugarModule
- , findModule
- , lookupModule
- ) where
-
-import Control.Monad
-import Control.Monad.IO.Class
-import Control.Exception (throwIO)
-
-import Data.IORef (readIORef)
-
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import Language.Haskell.Liquid.GHC.API hiding ( ModuleInfo
- , findModule
- , desugarModule
- , typecheckModule
- , parseModule
- , lookupName
- , lookupGlobalName
- , getModSummary
- , getModuleGraph
- , modInfoLookupName
- , lookupModule
- , TypecheckedModule
- , tm_parsed_module
- , tm_renamed_source
- )
-import qualified CoreMonad
-import qualified EnumSet
-import TcRnMonad
-import Outputable
-import UniqFM
-import Maybes
-import Panic
-import GhcMake
-import Finder
-import Exception (ExceptionMonad)
-
-import Optics
-
-class HasHscEnv m where
- askHscEnv :: m HscEnv
-
-instance HasHscEnv CoreMonad.CoreM where
- askHscEnv = CoreMonad.getHscEnv
-
-instance HasHscEnv Ghc where
- askHscEnv = getSession
-
-instance HasHscEnv (IfM lcl) where
- askHscEnv = getTopEnv
-
-instance HasHscEnv TcM where
- askHscEnv = env_top <$> getEnv
-
-instance HasHscEnv Hsc where
- askHscEnv = Hsc $ \e w -> pure (e, w)
-
-instance (ExceptionMonad m, HasHscEnv m) => HasHscEnv (GhcT m) where
- askHscEnv = getSession
-
--- | A typeclass which is /very/ similar to the existing 'GhcMonad', but it doesn't impose a
--- 'ExceptionMonad' constraint.
-class (Functor m, MonadIO m, HasHscEnv m, HasDynFlags m) => GhcMonadLike m
-
-instance GhcMonadLike CoreMonad.CoreM
-instance GhcMonadLike Ghc
-instance GhcMonadLike (IfM lcl)
-instance GhcMonadLike TcM
-instance GhcMonadLike Hsc
-instance (ExceptionMonad m, GhcMonadLike m) => GhcMonadLike (GhcT m)
-
--- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.
-getModuleGraph :: GhcMonadLike m => m ModuleGraph
-getModuleGraph = liftM hsc_mod_graph askHscEnv
-
--- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.
-getModSummary :: GhcMonadLike m => ModuleName -> m ModSummary
-getModSummary mdl = do
- mg <- liftM hsc_mod_graph askHscEnv
- let mods_by_name = [ ms | ms <- mgModSummaries mg
- , ms_mod_name ms == mdl
- , not (isBootSummary ms) ]
- case mods_by_name of
- [] -> do dflags <- getDynFlags
- liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
- [ms] -> return ms
- multiple -> do dflags <- getDynFlags
- liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
-
-lookupModSummary :: GhcMonadLike m => ModuleName -> m (Maybe ModSummary)
-lookupModSummary mdl = do
- mg <- liftM hsc_mod_graph askHscEnv
- let mods_by_name = [ ms | ms <- mgModSummaries mg
- , ms_mod_name ms == mdl
- , not (isBootSummary ms) ]
- case mods_by_name of
- [ms] -> pure (Just ms)
- _ -> pure Nothing
-
--- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.
-lookupGlobalName :: GhcMonadLike m => Name -> m (Maybe TyThing)
-lookupGlobalName name = do
- hsc_env <- askHscEnv
- liftIO $ lookupTypeHscEnv hsc_env name
-
--- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.
-lookupName :: GhcMonadLike m => Name -> m (Maybe TyThing)
-lookupName name = do
- hsc_env <- askHscEnv
- liftIO $ hscTcRcLookupName hsc_env name
-
--- | Our own simplified version of 'ModuleInfo' to overcome the fact we cannot construct the \"original\"
--- one as the constructor is not exported, and 'getHomeModuleInfo' and 'getPackageModuleInfo' are not
--- exported either, so we had to backport them as well.
-data ModuleInfo = ModuleInfo { minf_type_env :: UniqFM TyThing }
-
-modInfoLookupName :: GhcMonadLike m
- => ModuleInfo
- -> Name
- -> m (Maybe TyThing)
-modInfoLookupName minf name = do
- hsc_env <- askHscEnv
- case lookupTypeEnv (minf_type_env minf) name of
- Just tyThing -> return (Just tyThing)
- Nothing -> do
- eps <- liftIO $ readIORef (hsc_EPS hsc_env)
- return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name
-
-moduleInfoTc :: GhcMonadLike m => ModSummary -> TcGblEnv -> m ModuleInfo
-moduleInfoTc ms tcGblEnv = do
- hsc_env <- askHscEnv
- let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
- details <- md_types <$> liftIO (makeSimpleDetails hsc_env_tmp tcGblEnv)
- pure ModuleInfo { minf_type_env = details }
-
---
--- Parsing, typechecking and desugaring a module
---
-parseModule :: GhcMonadLike m => ModSummary -> m ParsedModule
-parseModule ms = do
- hsc_env <- askHscEnv
- let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
- hpm <- liftIO $ hscParse hsc_env_tmp ms
- return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
- (hpm_annotations hpm))
-
--- | Our own simplified version of 'TypecheckedModule'.
-data TypecheckedModule = TypecheckedModule {
- tm_parsed_module :: ParsedModule
- , tm_renamed_source :: Maybe RenamedSource
- , tm_mod_summary :: ModSummary
- , tm_gbl_env :: TcGblEnv
- }
-
-typecheckModule :: GhcMonadLike m => ParsedModule -> m TypecheckedModule
-typecheckModule pmod = do
- -- Suppress all the warnings, so that they won't be printed (which would result in them being
- -- printed twice, one by GHC and once here).
- let ms = pm_mod_summary pmod
- hsc_env <- askHscEnv
- let dynFlags' = ms_hspp_opts ms
- let hsc_env_tmp = hsc_env { hsc_dflags = dynFlags' { warningFlags = EnumSet.empty } }
- (tc_gbl_env, rn_info)
- <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
- HsParsedModule { hpm_module = parsedSource pmod,
- hpm_src_files = pm_extra_src_files pmod,
- hpm_annotations = pm_annotations pmod }
- return TypecheckedModule {
- tm_parsed_module = pmod
- , tm_renamed_source = rn_info
- , tm_mod_summary = ms
- , tm_gbl_env = tc_gbl_env
- }
-
-{- | [NOTE:ghc810]
-Something changed in the GHC bowels such that the 'hscTarget' that the 'ModSummary' was inheriting
-was /not/ the one we were setting in 'configureDynFlags'. This is important, because if the 'hscTarget'
-is not 'HscInterpreted' or 'HscNothing', the call to 'targetRetainsAllBindings' will yield 'False'. This
-function is used internally by GHC to do dead-code-elimination and to mark functions as "exported" or not.
-Therefore, the 'CoreBind's passed to LiquidHaskell would be different between GHC 8.6.5 and GHC 8.10.
--}
-
-class IsTypecheckedModule t where
- tmParsedModule :: Lens' t ParsedModule
- tmModSummary :: Lens' t ModSummary
- tmGblEnv :: Getter t TcGblEnv
-
-instance IsTypecheckedModule TypecheckedModule where
- tmParsedModule = lens tm_parsed_module (\s x -> s { tm_parsed_module = x })
- tmModSummary = lens tm_mod_summary (\s x -> s { tm_mod_summary = x })
- tmGblEnv = to tm_gbl_env
-
-instance IsTypecheckedModule Ghc.TypecheckedModule where
- tmParsedModule = lens Ghc.tm_parsed_module (\s x -> s { Ghc.tm_parsed_module = x })
- tmModSummary = lens (pm_mod_summary . Ghc.tm_parsed_module)
- (\s x -> over tmParsedModule (\pm -> pm { Ghc.pm_mod_summary = x }) s )
- tmGblEnv = to (fst . Ghc.tm_internals_)
-
--- | Desugar a typechecked module.
-desugarModule :: (GhcMonadLike m, IsTypecheckedModule t) => ModSummary -> t -> m ModGuts
-desugarModule originalModSum typechecked = do
- -- See [NOTE:ghc810] on why we override the dynFlags here before calling 'desugarModule'.
- dynFlags <- getDynFlags
- let modSum = originalModSum { ms_hspp_opts = dynFlags }
- let parsedMod' = (view tmParsedModule typechecked) { pm_mod_summary = modSum }
- let typechecked' = set tmParsedModule parsedMod' typechecked
-
- hsc_env <- askHscEnv
- let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts (view tmModSummary typechecked') }
- liftIO $ hscDesugar hsc_env_tmp (view tmModSummary typechecked') (view tmGblEnv typechecked')
-
--- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the
--- filesystem and package database to find the corresponding 'Module',
--- using the algorithm that is used for an @import@ declaration.
-findModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module
-findModule mod_name maybe_pkg = do
- hsc_env <- askHscEnv
- let
- dflags = hsc_dflags hsc_env
- this_pkg = thisPackage dflags
- --
- case maybe_pkg of
- Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
- res <- findImportedModule hsc_env mod_name maybe_pkg
- case res of
- Found _ m -> return m
- err -> throwOneError $ noModError dflags noSrcSpan mod_name err
- _otherwise -> do
- home <- lookupLoadedHomeModule mod_name
- case home of
- Just m -> return m
- Nothing -> liftIO $ do
- res <- findImportedModule hsc_env mod_name maybe_pkg
- case res of
- Found loc m | moduleUnitId m /= this_pkg -> return m
- | otherwise -> modNotLoadedError dflags m loc
- err -> throwOneError $ noModError dflags noSrcSpan mod_name err
-
-
-lookupLoadedHomeModule :: GhcMonadLike m => ModuleName -> m (Maybe Module)
-lookupLoadedHomeModule mod_name = do
- hsc_env <- askHscEnv
- case lookupHpt (hsc_HPT hsc_env) mod_name of
- Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
- _not_a_home_module -> return Nothing
-
-
-modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
-modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $
- text "module is not loaded:" <+>
- quotes (ppr (moduleName m)) <+>
- parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
-
-
-lookupModule :: GhcMonadLike m => ModuleName -> Maybe FastString -> m Module
-lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
-lookupModule mod_name Nothing = do
- hsc_env <- askHscEnv
- home <- lookupLoadedHomeModule mod_name
- case home of
- Just m -> return m
- Nothing -> liftIO $ do
- res <- findExposedPackageModule hsc_env mod_name Nothing
- case res of
- Found _ m -> return m
- err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
diff --git a/src/Language/Haskell/Liquid/GHC/Interface.hs b/src/Language/Haskell/Liquid/GHC/Interface.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/GHC/Interface.hs
+++ /dev/null
@@ -1,952 +0,0 @@
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module Language.Haskell.Liquid.GHC.Interface (
-
- -- * Determine the build-order for target files
- realTargets
-
- , getInterfaceDynFlags
-
- -- * Extract all information needed for verification
- , getTargetInfos
- , runLiquidGhc
-
- -- * Printer
- , pprintCBs
-
- -- * predicates
- -- , isExportedVar
- -- , exportedVars
-
- -- * Internal exports (provisional)
- , extractSpecComments
- , extractSpecQuotes'
- , makeLogicMap
- , classCons
- , derivedVars
- , importVars
- , makeGhcSrc
- , allImports
- , qualifiedImports
- , modSummaryHsFile
- , makeFamInstEnv
- , findAndParseSpecFiles
- , parseSpecFile
- , noTerm
- , clearSpec
- , checkFilePragmas
- , keepRawTokenStream
- , ignoreInline
- , lookupTyThings
- , availableTyCons
- , availableVars
- , updLiftedSpec
- , loadDependenciesOf
- ) where
-
-import Prelude hiding (error)
-
-import qualified Outputable as O
-import GHC hiding (Target, Located, desugarModule)
-import qualified GHC
-import GHC.Paths (libdir)
-import GHC.Serialized
-
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import Annotations
-import Avail
-import Class
-import CoreMonad
-import CoreSyn
-import DataCon
-import Digraph
-import DriverPhases
-import DriverPipeline
-import DynFlags
-import Finder
-import HscTypes hiding (Target)
-import IdInfo
-import InstEnv
-import Module
-import Panic (throwGhcExceptionIO)
--- import Serialized
-import TcRnTypes
-import Var
--- import NameSet
-import FastString
-import FamInstEnv
-import FamInst
-import qualified TysPrim
-import GHC.LanguageExtensions
-
-import Control.Exception
-import Control.Monad
-
-import Data.Bifunctor
-import Data.Data
-import Data.List hiding (intersperse)
-import Data.Maybe
-
-import Data.Generics.Aliases (mkT)
-import Data.Generics.Schemes (everywhere)
-
-import qualified Data.HashSet as S
-import qualified Data.Map as M
-import qualified Data.HashMap.Strict as HM
-
-import System.Console.CmdArgs.Verbosity hiding (Loud)
-import System.Directory
-import System.FilePath
-import System.IO.Temp
-import Text.Parsec.Pos
-import Text.PrettyPrint.HughesPJ hiding (first, (<>))
-import Language.Fixpoint.Types hiding (panic, Error, Result, Expr)
-import qualified Language.Fixpoint.Misc as Misc
-import Language.Haskell.Liquid.Bare
-import Language.Haskell.Liquid.GHC.Misc
-import Language.Haskell.Liquid.GHC.Types (MGIModGuts(..), miModGuts)
-import Language.Haskell.Liquid.GHC.Play
-import qualified Language.Haskell.Liquid.GHC.GhcMonadLike as GhcMonadLike
-import Language.Haskell.Liquid.GHC.GhcMonadLike (GhcMonadLike, askHscEnv)
-import Language.Haskell.Liquid.WiredIn (isDerivedInstance)
-import qualified Language.Haskell.Liquid.Measure as Ms
-import qualified Language.Haskell.Liquid.Misc as Misc
-import Language.Haskell.Liquid.Parse
-import Language.Haskell.Liquid.Transforms.ANF
-import Language.Haskell.Liquid.Types hiding (Spec)
--- import Language.Haskell.Liquid.Types.PrettyPrint
--- import Language.Haskell.Liquid.Types.Visitors
-import Language.Haskell.Liquid.UX.CmdLine
-import Language.Haskell.Liquid.UX.QuasiQuoter
-import Language.Haskell.Liquid.UX.Tidy
-import Language.Fixpoint.Utils.Files
-
-import Optics
-
-import qualified Debug.Trace as Debug
-
-
---------------------------------------------------------------------------------
-{- | @realTargets mE cfg targets@ uses `Interface.configureGhcTargets` to
- return a list of files
-
- [i1, i2, ... ] ++ [f1, f2, ...]
-
- 1. Where each file only (transitively imports) PRECEDIING ones;
- 2. `f1..` are a permutation of the original `targets`;
- 3. `i1..` either don't have "fresh" .bspec files.
-
- -}
---------------------------------------------------------------------------------
-realTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath]
-realTargets mbEnv cfg tgtFs
- | noCheckImports cfg = return tgtFs
- | otherwise = do
- incDir <- Misc.getIncludeDir
- allFs <- orderTargets mbEnv cfg tgtFs
- let srcFs = filter (not . Misc.isIncludeFile incDir) allFs
- realFs <- filterM check srcFs
- dir <- getCurrentDirectory
- return (makeRelative dir <$> realFs)
- where
- check f = not <$> skipTarget tgts f
- tgts = S.fromList tgtFs
-
-getInterfaceDynFlags :: Maybe HscEnv -> Config -> IO DynFlags
-getInterfaceDynFlags mbEnv cfg = runLiquidGhc mbEnv cfg $ getSessionDynFlags
-
-orderTargets :: Maybe HscEnv -> Config -> [FilePath] -> IO [FilePath]
-orderTargets mbEnv cfg tgtFiles = runLiquidGhc mbEnv cfg $ do
- homeModules <- configureGhcTargets tgtFiles
- return (modSummaryHsFile <$> mgModSummaries homeModules)
-
-
-skipTarget :: S.HashSet FilePath -> FilePath -> IO Bool
-skipTarget tgts f
- | S.member f tgts = return False -- Always check target file
- | otherwise = hasFreshBinSpec f -- But skip an import with fresh .bspec
-
-hasFreshBinSpec :: FilePath -> IO Bool
-hasFreshBinSpec srcF = do
- let specF = extFileName BinSpec srcF
- srcMb <- Misc.lastModified srcF
- specMb <- Misc.lastModified specF
- case (srcMb, specMb) of
- (Just srcT, Just specT) -> return (srcT < specT)
- _ -> return False
-
-
-
---------------------------------------------------------------------------------
--- | GHC Interface Pipeline ----------------------------------------------------
---------------------------------------------------------------------------------
-
-getTargetInfos :: Maybe HscEnv -> Config -> [FilePath] -> IO ([TargetInfo], HscEnv)
-getTargetInfos hscEnv cfg tgtFiles' = do
- tgtFiles <- mapM canonicalizePath tgtFiles'
- _ <- mapM checkFilePresent tgtFiles
- _ <- mapM_ createTempDirectoryIfMissing tgtFiles
- logicMap <- liftIO makeLogicMap
- runLiquidGhc hscEnv cfg (getTargetInfos' cfg logicMap tgtFiles)
-
-checkFilePresent :: FilePath -> IO ()
-checkFilePresent f = do
- b <- doesFileExist f
- unless b $ panic Nothing ("Cannot find file: " ++ f)
-
-getTargetInfos' :: Config -> LogicMap -> [FilePath] -> Ghc ([TargetInfo], HscEnv)
-getTargetInfos' cfg logicMap tgtFiles = do
- _ <- compileCFiles cfg
- homeModules <- configureGhcTargets tgtFiles
- depGraph <- buildDepGraph homeModules
- ghcInfos <- processModules cfg logicMap tgtFiles depGraph homeModules
- hscEnv <- getSession
- return (ghcInfos, hscEnv)
-
-createTempDirectoryIfMissing :: FilePath -> IO ()
-createTempDirectoryIfMissing tgtFile = Misc.tryIgnore "create temp directory" $
- createDirectoryIfMissing False $ tempDirectory tgtFile
-
---------------------------------------------------------------------------------
--- | GHC Configuration & Setup -------------------------------------------------
---------------------------------------------------------------------------------
-runLiquidGhc :: Maybe HscEnv -> Config -> Ghc a -> IO a
-runLiquidGhc hscEnv cfg act =
- withSystemTempDirectory "liquid" $ \tmp ->
- runGhc (Just libdir) $ do
- maybe (return ()) setSession hscEnv
- df <- configureDynFlags cfg tmp
- prettyPrintGhcErrors df act
-
-updateIncludePaths :: DynFlags -> [FilePath] -> IncludeSpecs
-updateIncludePaths df ps = addGlobalInclude (includePaths df) ps
-
-configureDynFlags :: Config -> FilePath -> Ghc DynFlags
-configureDynFlags cfg tmp = do
- df <- getSessionDynFlags
- (df',_,_) <- parseDynamicFlags df $ map noLoc $ ghcOptions cfg
- loud <- liftIO isLoud
- let df'' = df' { importPaths = nub $ idirs cfg ++ importPaths df'
- , libraryPaths = nub $ idirs cfg ++ libraryPaths df'
- , includePaths = updateIncludePaths df' (idirs cfg) -- addGlobalInclude (includePaths df') (idirs cfg)
- , packageFlags = ExposePackage ""
- (PackageArg "ghc-prim")
- (ModRenaming True [])
- : (packageFlags df')
-
- , debugLevel = 1 -- insert SourceNotes
- -- , profAuto = ProfAutoCalls
- , ghcLink = LinkInMemory
- , hscTarget = HscInterpreted
- , ghcMode = CompManager
- -- prevent GHC from printing anything, unless in Loud mode
- , log_action = if loud
- then defaultLogAction
- else \_ _ _ _ _ _ -> return ()
- -- redirect .hi/.o/etc files to temp directory
- , objectDir = Just tmp
- , hiDir = Just tmp
- , stubDir = Just tmp
- } `gopt_set` Opt_ImplicitImportQualified
- `gopt_set` Opt_PIC
- `gopt_set` Opt_DeferTypedHoles
- `xopt_set` MagicHash
- `xopt_set` DeriveGeneric
- `xopt_set` StandaloneDeriving
- _ <- setSessionDynFlags df''
- return df''
-
-configureGhcTargets :: [FilePath] -> Ghc ModuleGraph
-configureGhcTargets tgtFiles = do
- targets <- mapM (`guessTarget` Nothing) tgtFiles
- _ <- setTargets targets
- moduleGraph <- depanal [] False -- see [NOTE:DROP-BOOT-FILES]
-
- let homeModules = filter (not . isBootSummary) $
- flattenSCCs $ topSortModuleGraph False moduleGraph Nothing
- let homeNames = moduleName . ms_mod <$> homeModules
- _ <- setTargetModules homeNames
- liftIO $ whenLoud $ print ("Module Dependencies", homeNames)
- return $ mkModuleGraph homeModules
-
-setTargetModules :: [ModuleName] -> Ghc ()
-setTargetModules modNames = setTargets $ mkTarget <$> modNames
- where
- mkTarget modName = GHC.Target (TargetModule modName) True Nothing
-
-compileCFiles :: Config -> Ghc ()
-compileCFiles cfg = do
- df <- getSessionDynFlags
- _ <- setSessionDynFlags $
- df { includePaths = updateIncludePaths df (idirs cfg)
- , importPaths = nub $ idirs cfg ++ importPaths df
- , libraryPaths = nub $ idirs cfg ++ libraryPaths df }
- hsc <- getSession
- os <- mapM (\x -> liftIO $ compileFile hsc StopLn (x,Nothing)) (nub $ cFiles cfg)
- df <- getSessionDynFlags
- void $ setSessionDynFlags $ df { ldInputs = nub $ map (FileOption "") os ++ ldInputs df }
-
-{- | [NOTE:DROP-BOOT-FILES] Drop hs-boot files from the graph.
- We do it manually rather than using the flag to topSortModuleGraph
- because otherwise the order of mutually recursive modules depends
- on the modulename, e.g. given
-
- Bar.hs --> Foo.hs --> Bar.hs-boot
-
- we'll get
-
- [Bar.hs, Foo.hs]
-
- which is backwards..
- -}
---------------------------------------------------------------------------------
--- Home Module Dependency Graph ------------------------------------------------
---------------------------------------------------------------------------------
-
-type DepGraph = Graph DepGraphNode
-type DepGraphNode = Node Module ()
-
-reachableModules :: DepGraph -> Module -> [Module]
-reachableModules depGraph mod =
- node_key <$> tail (reachableG depGraph (DigraphNode () mod []))
-
-buildDepGraph :: ModuleGraph -> Ghc DepGraph
-buildDepGraph homeModules =
- graphFromEdgedVerticesOrd <$> mapM mkDepGraphNode (mgModSummaries homeModules)
-
-mkDepGraphNode :: ModSummary -> Ghc DepGraphNode
-mkDepGraphNode modSummary =
- DigraphNode () (ms_mod modSummary) <$> (filterM isHomeModule =<< modSummaryImports modSummary)
-
-isHomeModule :: GhcMonadLike m => Module -> m Bool
-isHomeModule mod = do
- homePkg <- thisPackage <$> getDynFlags
- return $ moduleUnitId mod == homePkg
-
-modSummaryImports :: GhcMonadLike m => ModSummary -> m [Module]
-modSummaryImports modSummary =
- mapM (importDeclModule (ms_mod modSummary))
- (ms_textual_imps modSummary)
-
-importDeclModule :: GhcMonadLike m => Module -> (Maybe FastString, GHC.Located ModuleName) -> m Module
-importDeclModule fromMod (pkgQual, locModName) = do
- hscEnv <- askHscEnv
- let modName = unLoc locModName
- result <- liftIO $ findImportedModule hscEnv modName pkgQual
- case result of
- Finder.Found _ mod -> return mod
- _ -> do
- dflags <- getDynFlags
- liftIO $ throwGhcExceptionIO $ ProgramError $
- O.showPpr dflags (moduleName fromMod) ++ ": " ++
- O.showSDoc dflags (cannotFindModule dflags modName result)
-
---------------------------------------------------------------------------------
--- | Extract Ids ---------------------------------------------------------------
---------------------------------------------------------------------------------
-
-classCons :: Maybe [ClsInst] -> [Id]
-classCons Nothing = []
-classCons (Just cs) = concatMap (dataConImplicitIds . head . tyConDataCons . classTyCon . is_cls) cs
-
-derivedVars :: Config -> MGIModGuts -> [Var]
-derivedVars cfg mg = concatMap (dFunIdVars cbs . is_dfun) derInsts
- where
- derInsts
- | checkDer = insts
- | otherwise = filter isDerivedInstance insts
- insts = mgClsInstances mg
- checkDer = checkDerived cfg
- cbs = mgi_binds mg
-
-
-mgClsInstances :: MGIModGuts -> [ClsInst]
-mgClsInstances = fromMaybe [] . mgi_cls_inst
-
-dFunIdVars :: CoreProgram -> DFunId -> [Id]
-dFunIdVars cbs fd = notracepp msg $ concatMap bindersOf cbs' ++ deps
- where
- msg = "DERIVED-VARS-OF: " ++ showpp fd
- cbs' = filter f cbs
- f (NonRec x _) = eqFd x
- f (Rec xes) = any eqFd (fst <$> xes)
- eqFd x = varName x == varName fd
- deps = concatMap unfoldDep unfolds
- unfolds = unfoldingInfo . idInfo <$> concatMap bindersOf cbs'
-
-unfoldDep :: Unfolding -> [Id]
-unfoldDep (DFunUnfolding _ _ e) = concatMap exprDep e
-unfoldDep CoreUnfolding {uf_tmpl = e} = exprDep e
-unfoldDep _ = []
-
-exprDep :: CoreExpr -> [Id]
-exprDep = freeVars S.empty
-
-importVars :: CoreProgram -> [Id]
-importVars = freeVars S.empty
-
-_definedVars :: CoreProgram -> [Id]
-_definedVars = concatMap defs
- where
- defs (NonRec x _) = [x]
- defs (Rec xes) = map fst xes
-
---------------------------------------------------------------------------------
--- | Per-Module Pipeline -------------------------------------------------------
---------------------------------------------------------------------------------
-
-type SpecEnv = ModuleEnv (ModName, Ms.BareSpec)
-
-processModules :: Config -> LogicMap -> [FilePath] -> DepGraph -> ModuleGraph -> Ghc [TargetInfo]
-processModules cfg logicMap tgtFiles depGraph homeModules = do
- -- DO NOT DELETE: liftIO $ putStrLn $ "Process Modules: TargetFiles = " ++ show tgtFiles
- catMaybes . snd <$> Misc.mapAccumM go emptyModuleEnv (mgModSummaries homeModules)
- where
- go = processModule cfg logicMap (S.fromList tgtFiles) depGraph
-
-processModule :: Config -> LogicMap -> S.HashSet FilePath -> DepGraph -> SpecEnv -> ModSummary
- -> Ghc (SpecEnv, Maybe TargetInfo)
-processModule cfg logicMap tgtFiles depGraph specEnv modSummary = do
- let mod = ms_mod modSummary
- -- DO-NOT-DELETE _ <- liftIO $ whenLoud $ putStrLn $ "Process Module: " ++ showPpr (moduleName mod)
- file <- liftIO $ canonicalizePath $ modSummaryHsFile modSummary
- let isTarget = file `S.member` tgtFiles
- _ <- loadDependenciesOf $ moduleName mod
- parsed <- parseModule $ keepRawTokenStream modSummary
- let specComments = extractSpecComments (pm_annotations parsed)
- typechecked <- typecheckModule $ ignoreInline parsed
- let specQuotes = extractSpecQuotes typechecked
- _ <- loadModule' typechecked
- (modName, commSpec) <- either throw return $ hsSpecificationP (moduleName mod) specComments specQuotes
-
- liftedSpec <- liftIO $ if isTarget || null specComments then return Nothing else loadLiftedSpec cfg file
- let bareSpec = updLiftedSpec commSpec liftedSpec
- _ <- checkFilePragmas $ Ms.pragmas bareSpec
- let specEnv' = extendModuleEnv specEnv mod (modName, noTerm bareSpec)
- (specEnv', ) <$> if isTarget
- then Just <$> processTargetModule cfg logicMap depGraph specEnv file typechecked bareSpec
- else return Nothing
-
-updLiftedSpec :: Ms.BareSpec -> Maybe Ms.BareSpec -> Ms.BareSpec
-updLiftedSpec s1 Nothing = s1
-updLiftedSpec s1 (Just s2) = (clearSpec s1) `mappend` s2
-
-clearSpec :: Ms.BareSpec -> Ms.BareSpec
-clearSpec s = s { sigs = [], asmSigs = [], aliases = [], ealiases = [], qualifiers = [], dataDecls = [] }
-
-keepRawTokenStream :: ModSummary -> ModSummary
-keepRawTokenStream modSummary = modSummary
- { ms_hspp_opts = ms_hspp_opts modSummary `gopt_set` Opt_KeepRawTokenStream }
-
-loadDependenciesOf :: GhcMonad m => ModuleName -> m ()
-loadDependenciesOf modName = do
- loadResult <- load $ LoadDependenciesOf modName
- when (failed loadResult) $ liftIO $ throwGhcExceptionIO $ ProgramError $
- "Failed to load dependencies of module " ++ showPpr modName
-
-loadModule' :: TypecheckedModule -> Ghc TypecheckedModule
-loadModule' tm = loadModule tm'
- where
- pm = tm_parsed_module tm
- ms = pm_mod_summary pm
- df = ms_hspp_opts ms
- df' = df { hscTarget = HscNothing, ghcLink = NoLink }
- ms' = ms { ms_hspp_opts = df' }
- pm' = pm { pm_mod_summary = ms' }
- tm' = tm { tm_parsed_module = pm' }
-
-
-processTargetModule :: Config -> LogicMap -> DepGraph -> SpecEnv -> FilePath -> TypecheckedModule -> Ms.BareSpec
- -> Ghc TargetInfo
-processTargetModule cfg0 logicMap depGraph specEnv file typechecked bareSpec = do
- cfg <- liftIO $ withPragmas cfg0 file (Ms.pragmas bareSpec)
- let modSum = pm_mod_summary (tm_parsed_module typechecked)
- ghcSrc <- makeGhcSrc cfg file typechecked modSum
- dependencies <- makeDependencies cfg depGraph specEnv modSum bareSpec
-
- let targetSrc = view targetSrcIso ghcSrc
- dynFlags <- getDynFlags
-
- case makeTargetSpec cfg logicMap targetSrc (view bareSpecIso bareSpec) dependencies of
- Left diagnostics -> do
- mapM_ (liftIO . printWarning dynFlags) (allWarnings diagnostics)
- throw (allErrors diagnostics)
- Right (warns, targetSpec, liftedSpec) -> do
- mapM_ (liftIO . printWarning dynFlags) warns
- -- The call below is temporary, we should really load & save directly 'LiftedSpec's.
- _ <- liftIO $ saveLiftedSpec (_giTarget ghcSrc) (unsafeFromLiftedSpec liftedSpec)
- return $ TargetInfo targetSrc targetSpec
-
----------------------------------------------------------------------------------------
--- | @makeGhcSrc@ builds all the source-related information needed for consgen
----------------------------------------------------------------------------------------
-
-makeGhcSrc :: Config -> FilePath -> TypecheckedModule -> ModSummary -> Ghc GhcSrc
-makeGhcSrc cfg file typechecked modSum = do
- modGuts' <- GhcMonadLike.desugarModule modSum typechecked
-
- let modGuts = makeMGIModGuts modGuts'
- hscEnv <- getSession
- coreBinds <- liftIO $ anormalize cfg hscEnv modGuts'
- _ <- liftIO $ whenNormal $ Misc.donePhase Misc.Loud "A-Normalization"
- let dataCons = concatMap (map dataConWorkId . tyConDataCons) (mgi_tcs modGuts)
- (fiTcs, fiDcs) <- makeFamInstEnv <$> liftIO (getFamInstances hscEnv)
- things <- lookupTyThings hscEnv modSum (fst $ tm_internals_ typechecked)
-
- availableTcs <- availableTyCons hscEnv modSum (fst $ tm_internals_ typechecked) (mg_exports modGuts')
-
- let impVars = importVars coreBinds ++ classCons (mgi_cls_inst modGuts)
- incDir <- liftIO $ Misc.getIncludeDir
-
- --liftIO $ do
- -- print $ "_gsTcs => " ++ show (nub $ (mgi_tcs modGuts) ++ availableTcs)
- -- print $ "_gsFiTcs => " ++ show fiTcs
- -- print $ "_gsFiDcs => " ++ show fiDcs
- -- print $ "dataCons => " ++ show dataCons
- -- print $ "defVars => " ++ show (dataCons ++ (letVars coreBinds))
-
- return $ Src
- { _giIncDir = incDir
- , _giTarget = file
- , _giTargetMod = ModName Target (moduleName (ms_mod modSum))
- , _giCbs = coreBinds
- , _giImpVars = impVars
- , _giDefVars = dataCons ++ (letVars coreBinds)
- , _giUseVars = readVars coreBinds
- , _giDerVars = S.fromList (derivedVars cfg modGuts)
- , _gsExports = mgi_exports modGuts
- , _gsTcs = nub $ (mgi_tcs modGuts) ++ availableTcs
- , _gsCls = mgi_cls_inst modGuts
- , _gsFiTcs = fiTcs
- , _gsFiDcs = fiDcs
- , _gsPrimTcs = TysPrim.primTyCons
- , _gsQualImps = qualifiedImports (maybe mempty (view _2) (tm_renamed_source typechecked))
- , _gsAllImps = allImports (maybe mempty (view _2) (tm_renamed_source typechecked))
- , _gsTyThings = [ t | (_, Just t) <- things ]
- }
-
-_impThings :: [Var] -> [TyThing] -> [TyThing]
-_impThings vars = filter ok
- where
- vs = S.fromList vars
- ok (AnId x) = S.member x vs
- ok _ = True
-
-allImports :: [LImportDecl GhcRn] -> S.HashSet Symbol
-allImports = \case
- []-> Debug.trace "WARNING: Missing RenamedSource" mempty
- imps -> S.fromList (symbol . unLoc . ideclName . unLoc <$> imps)
-
-qualifiedImports :: [LImportDecl GhcRn] -> QImports
-qualifiedImports = \case
- [] -> Debug.trace "WARNING: Missing RenamedSource" (qImports mempty)
- imps -> qImports [ (qn, n) | i <- imps
- , let decl = unLoc i
- , let m = unLoc (ideclName decl)
- , qm <- maybeToList (unLoc <$> ideclAs decl)
- , let [n,qn] = symbol <$> [m, qm]
- ]
-
-qImports :: [(Symbol, Symbol)] -> QImports
-qImports qns = QImports
- { qiNames = Misc.group qns
- , qiModules = S.fromList (snd <$> qns)
- }
-
-
----------------------------------------------------------------------------------------
--- | @lookupTyThings@ grabs all the @Name@s and associated @TyThing@ known to GHC
--- for this module; we will use this to create our name-resolution environment
--- (see `Bare.Resolve`)
----------------------------------------------------------------------------------------
-lookupTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> m [(Name, Maybe TyThing)]
-lookupTyThings hscEnv modSum tcGblEnv = forM names (lookupTyThing hscEnv modSum tcGblEnv)
- where
- names :: [Ghc.Name]
- names = fmap Ghc.gre_name . Ghc.globalRdrEnvElts $ tcg_rdr_env tcGblEnv
-
--- | Lookup a single 'Name' in the GHC environment, yielding back the 'Name' alongside the 'TyThing',
--- if one is found.
-lookupTyThing :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> Name -> m (Name, Maybe TyThing)
-lookupTyThing hscEnv modSum tcGblEnv n = do
- mi <- GhcMonadLike.moduleInfoTc modSum tcGblEnv
- tt1 <- GhcMonadLike.lookupName n
- tt2 <- liftIO $ Ghc.hscTcRcLookupName hscEnv n
- tt3 <- GhcMonadLike.modInfoLookupName mi n
- tt4 <- GhcMonadLike.lookupGlobalName n
- return (n, Misc.firstMaybes [tt1, tt2, tt3, tt4])
-
-availableTyThings :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [TyThing]
-availableTyThings hscEnv modSum tcGblEnv avails = fmap (catMaybes . mconcat) $ forM avails $ \a -> do
- results <- case a of
- Avail n -> pure <$> lookupTyThing hscEnv modSum tcGblEnv n
- AvailTC n ns _ -> forM (n : ns) $ lookupTyThing hscEnv modSum tcGblEnv
- pure . map snd $ results
-
--- | Returns all the available (i.e. exported) 'TyCon's (type constructors) for the input 'Module'.
-availableTyCons :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [GHC.TyCon]
-availableTyCons hscEnv modSum tcGblEnv avails =
- fmap (\things -> [tyCon | (ATyCon tyCon) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)
-
--- | Returns all the available (i.e. exported) 'Var's for the input 'Module'.
-availableVars :: GhcMonadLike m => HscEnv -> ModSummary -> TcGblEnv -> [AvailInfo] -> m [Ghc.Var]
-availableVars hscEnv modSum tcGblEnv avails =
- fmap (\things -> [var | (AnId var) <- things]) (availableTyThings hscEnv modSum tcGblEnv avails)
-
--- lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
--- hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
--- modInfoLookupName :: GhcMonad m => ModuleInfo -> Name -> m (Maybe TyThing)
--- lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
-
-_dumpTypeEnv :: TypecheckedModule -> IO ()
-_dumpTypeEnv tm = do
- print "DUMP-TYPE-ENV"
- print (showpp <$> tcmTyThings tm)
-
-tcmTyThings :: TypecheckedModule -> Maybe [Name]
-tcmTyThings
- = id
- -- typeEnvElts
- -- . tcg_type_env . fst
- -- . md_types . snd
- -- . tm_internals_
- . modInfoTopLevelScope
- . tm_checked_module_info
-
-
-_dumpRdrEnv :: HscEnv -> MGIModGuts -> IO ()
-_dumpRdrEnv _hscEnv modGuts = do
- print "DUMP-RDR-ENV"
- print (mgNames modGuts)
- -- print (hscNames hscEnv)
- -- print (mgDeps modGuts)
- where
- _mgDeps = Ghc.dep_mods . mgi_deps
- _hscNames = fmap showPpr . Ghc.ic_tythings . Ghc.hsc_IC
-
-mgNames :: MGIModGuts -> [Ghc.Name]
-mgNames = fmap Ghc.gre_name . Ghc.globalRdrEnvElts . mgi_rdr_env
-
----------------------------------------------------------------------------------------
--- | @makeDependencies@ loads BareSpec for target and imported modules
--- /IMPORTANT(adn)/: We \"cheat\" a bit by creating a 'Module' out the 'ModuleName' we
--- parse from the spec, and convert the former into a 'StableModule' for the purpose
--- of dependency tracking. This means, in practice, that all the \"wired-in-prelude\"
--- specs will share the same `UnitId`, which for the sake of the executable is an
--- acceptable compromise, as long as we don't create duplicates.
----------------------------------------------------------------------------------------
-makeDependencies :: Config -> DepGraph -> SpecEnv -> ModSummary -> Ms.BareSpec
- -> Ghc TargetDependencies
-makeDependencies cfg depGraph specEnv modSum _ = do
- let paths = S.fromList $ idirs cfg ++ importPaths (ms_hspp_opts modSum)
- _ <- liftIO $ whenLoud $ putStrLn $ "paths = " ++ show paths
- let reachable = reachableModules depGraph (ms_mod modSum)
- specSpecs <- findAndParseSpecFiles cfg paths modSum reachable
- let homeSpecs = cachedBareSpecs specEnv reachable
-
- -- NOTE:(adn) Unfortunately for the executable we might have 3 different 'Prelude' specs
- -- (one for the Prelude functions, one for the Real/NonReal and one for the PatErr, so we
- -- cannot really assume all the module names will be disjointed. As a result we have to
- -- hack our way around this by replacing the 'UnitId' with some unique enumeration, at
- -- least unique in this local scope.
-
- let combine ix (mn, sp) = ((mn, ix), sp)
- let impSpecs = map (bimap mkStableModule (view liftedSpecGetter)) (zipWith combine [0..] (specSpecs ++ homeSpecs))
-
- return $ TargetDependencies $ HM.fromList impSpecs
- where
- mkStableModule :: (ModName, Int) -> StableModule
- mkStableModule (modName, ix) =
- toStableModule (Module (fakeUnitId (moduleUnitId targetModule) ix) (getModName modName))
-
- fakeUnitId :: UnitId -> Int -> UnitId
- fakeUnitId uid ix = stringToUnitId $ unitIdString uid ++ show ix
-
- targetModule :: Module
- targetModule = ms_mod modSum
-
-modSummaryHsFile :: ModSummary -> FilePath
-modSummaryHsFile modSummary =
- fromMaybe
- (panic Nothing $
- "modSummaryHsFile: missing .hs file for " ++
- showPpr (ms_mod modSummary))
- (ml_hs_file $ ms_location modSummary)
-
-cachedBareSpecs :: SpecEnv -> [Module] -> [(ModName, Ms.BareSpec)]
-cachedBareSpecs specEnv mods = lookupBareSpec <$> mods
- where
- lookupBareSpec m = fromMaybe (err m) (lookupModuleEnv specEnv m)
- err m = impossible Nothing ("lookupBareSpec: missing module " ++ showPpr m)
-
-checkFilePragmas :: GhcMonadLike m => [Located String] -> m ()
-checkFilePragmas = Misc.applyNonNull (return ()) throw . mapMaybe err
- where
- err pragma
- | check (val pragma) = Just (ErrFilePragma $ fSrcSpan pragma :: Error)
- | otherwise = Nothing
- check pragma = any (`isPrefixOf` pragma) bad
- bad =
- [ "-i", "--idirs"
- , "-g", "--ghc-option"
- , "--c-files", "--cfiles"
- ]
-
---------------------------------------------------------------------------------
--- | Family instance information
---------------------------------------------------------------------------------
-makeFamInstEnv :: [FamInst] -> ([GHC.TyCon], [(Symbol, DataCon)])
-makeFamInstEnv famInsts =
- let fiTcs = [ tc | FamInst { fi_flavor = DataFamilyInst tc } <- famInsts ]
- fiDcs = [ (symbol d, d) | tc <- fiTcs, d <- tyConDataCons tc ]
- in (fiTcs, fiDcs)
-
-getFamInstances :: HscEnv -> IO [FamInst]
-getFamInstances env = do
- (_, Just (pkg_fie, home_fie)) <- runTcInteractive env tcGetFamInstEnvs
- return $ famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
-
---------------------------------------------------------------------------------
--- | Extract Specifications from GHC -------------------------------------------
---------------------------------------------------------------------------------
-extractSpecComments :: ApiAnns -> [(SourcePos, String)]
-extractSpecComments = mapMaybe extractSpecComment
- . concat
- . M.elems
- . snd
-
-
--- | 'extractSpecComment' pulls out the specification part from a full comment
--- string, i.e. if the string is of the form:
--- 1. '{-@ S @-}' then it returns the substring 'S',
--- 2. '{-@ ... -}' then it throws a malformed SPECIFICATION ERROR, and
--- 3. Otherwise it is just treated as a plain comment so we return Nothing.
-extractSpecComment :: GHC.Located AnnotationComment -> Maybe (SourcePos, String)
-
-extractSpecComment (GHC.L sp (AnnBlockComment text))
- | isPrefixOf "{-@" text && isSuffixOf "@-}" text -- valid specification
- = Just (offsetPos, take (length text - 6) $ drop 3 text)
- | isPrefixOf "{-@" text -- invalid specification
- = uError $ ErrParseAnn sp "A valid specification must have a closing '@-}'."
- where
- offsetPos = incSourceColumn (srcSpanSourcePos sp) 3
-extractSpecComment _ = Nothing
-
-extractSpecQuotes :: TypecheckedModule -> [BPspec]
-extractSpecQuotes =
- extractSpecQuotes' (ms_mod . pm_mod_summary . tm_parsed_module)
- (tcg_anns . fst . tm_internals_)
-
-extractSpecQuotes' :: (a -> Module) -> (a -> [Annotation]) -> a -> [BPspec]
-extractSpecQuotes' thisModule getAnns a = mapMaybe extractSpecQuote anns
- where
- anns = map ann_value $
- filter (isOurModTarget . ann_target) $
- getAnns a
-
- isOurModTarget (ModuleTarget mod1) = mod1 == thisModule a
- isOurModTarget _ = False
-
-extractSpecQuote :: AnnPayload -> Maybe BPspec
-extractSpecQuote payload =
- case fromSerialized deserializeWithData payload of
- Nothing -> Nothing
- Just qt -> Just $ refreshSymbols $ liquidQuoteSpec qt
-
-refreshSymbols :: Data a => a -> a
-refreshSymbols = everywhere (mkT refreshSymbol)
-
-refreshSymbol :: Symbol -> Symbol
-refreshSymbol = symbol . symbolText
-
---------------------------------------------------------------------------------
--- | Finding & Parsing Files ---------------------------------------------------
---------------------------------------------------------------------------------
-
--- | Handle Spec Files ---------------------------------------------------------
-
-findAndParseSpecFiles :: GhcMonadLike m
- => Config
- -> S.HashSet FilePath
- -> ModSummary
- -> [Module]
- -> m [(ModName, Ms.BareSpec)]
-findAndParseSpecFiles cfg paths modSummary reachable = do
- modGraph <- GhcMonadLike.getModuleGraph
- impSumms <- mapM GhcMonadLike.getModSummary (moduleName <$> reachable)
- imps'' <- nub . concat <$> mapM modSummaryImports (modSummary : impSumms)
- imps' <- filterM ((not <$>) . isHomeModule) imps''
- let imps = m2s <$> imps'
- fs' <- liftIO $ moduleFiles modGraph Spec paths imps
- -- liftIO $ whenLoud $ print ("moduleFiles-imps'': " ++ show (m2s <$> imps''))
- -- liftIO $ whenLoud $ print ("moduleFiles-imps' : " ++ show (m2s <$> imps'))
- -- liftIO $ whenLoud $ print ("moduleFiles-imps : " ++ show imps)
- -- liftIO $ whenLoud $ print ("moduleFiles-Paths : " ++ show paths)
- -- liftIO $ whenLoud $ print ("moduleFiles-Specs : " ++ show fs')
- patSpec <- liftIO $ getPatSpec modGraph paths $ totalityCheck cfg
- rlSpec <- liftIO $ getRealSpec modGraph paths $ not (linear cfg)
- let fs = patSpec ++ rlSpec ++ fs'
- liftIO $ transParseSpecs modGraph paths mempty mempty fs
- where
- m2s = moduleNameString . moduleName
-
-getPatSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]
-getPatSpec modGraph paths totalitycheck
- | totalitycheck = moduleFiles modGraph Spec paths [patErrorName]
- | otherwise = return []
- where
- patErrorName = "PatErr"
-
-getRealSpec :: ModuleGraph -> S.HashSet FilePath -> Bool -> IO [FilePath]
-getRealSpec modGraph paths freal
- | freal = moduleFiles modGraph Spec paths [realSpecName]
- | otherwise = moduleFiles modGraph Spec paths [notRealSpecName]
- where
- realSpecName = "Real"
- notRealSpecName = "NotReal"
-
-transParseSpecs :: ModuleGraph
- -> S.HashSet FilePath
- -> S.HashSet FilePath
- -> [(ModName, Ms.BareSpec)]
- -> [FilePath]
- -> IO [(ModName, Ms.BareSpec)]
-transParseSpecs _ _ _ specs [] = return specs
-transParseSpecs modGraph paths seenFiles specs newFiles = do
- -- liftIO $ print ("TRANS-PARSE-SPECS", seenFiles, newFiles)
- newSpecs <- liftIO $ mapM parseSpecFile newFiles
- impFiles <- moduleFiles modGraph Spec paths $ specsImports newSpecs
- let seenFiles' = seenFiles `S.union` S.fromList newFiles
- let specs' = specs ++ map (second noTerm) newSpecs
- let newFiles' = filter (not . (`S.member` seenFiles')) impFiles
- transParseSpecs modGraph paths seenFiles' specs' newFiles'
- where
- specsImports ss = nub $ concatMap (map symbolString . Ms.imports . snd) ss
-
-noTerm :: Ms.BareSpec -> Ms.BareSpec
-noTerm spec = spec { Ms.decr = mempty, Ms.lazy = mempty, Ms.termexprs = mempty }
-
-parseSpecFile :: FilePath -> IO (ModName, Ms.BareSpec)
-parseSpecFile file = either throw return . specSpecificationP file =<< Misc.sayReadFile file
-
--- Find Hquals Files -----------------------------------------------------------
-
--- _moduleHquals :: MGIModGuts
--- -> [FilePath]
--- -> FilePath
--- -> [String]
--- -> [FilePath]
--- -> Ghc [FilePath]
--- _moduleHquals mgi paths target imps incs = do
--- hqs <- specIncludes Hquals paths incs
--- hqs' <- moduleFiles Hquals paths (mgi_namestring mgi : imps)
--- hqs'' <- liftIO $ filterM doesFileExist [extFileName Hquals target]
--- return $ Misc.sortNub $ hqs'' ++ hqs ++ hqs'
-
--- Find Files for Modules ------------------------------------------------------
-
-moduleFiles :: ModuleGraph -> Ext -> S.HashSet FilePath -> [String] -> IO [FilePath]
-moduleFiles modGraph ext paths names = catMaybes <$> mapM (moduleFile modGraph ext paths) names
-
-moduleFile :: ModuleGraph -> Ext -> S.HashSet FilePath -> String -> IO (Maybe FilePath)
-moduleFile modGraph ext (S.toList -> paths) name
- | ext `elem` [Hs, LHs] = do
- let graph = mgModSummaries modGraph
- case find (\m -> not (isBootSummary m) &&
- name == moduleNameString (ms_mod_name m)) graph of
- Nothing -> getFileInDirs (extModuleName name ext) paths
- Just ms -> return $ normalise <$> ml_hs_file (ms_location ms)
- | otherwise = getFileInDirs (extModuleName name ext) paths
-
---------------------------------------------------------------------------------
--- Assemble Information for Spec Extraction ------------------------------------
---------------------------------------------------------------------------------
-
-makeMGIModGuts :: ModGuts -> MGIModGuts
-makeMGIModGuts modGuts = miModGuts deriv modGuts
- where
- deriv = Just $ instEnvElts $ mg_inst_env modGuts
-
-makeLogicMap :: IO LogicMap
-makeLogicMap = do
- lg <- Misc.getCoreToLogicPath
- lspec <- Misc.sayReadFile lg
- case parseSymbolToLogic lg lspec of
- Left e -> throw e
- Right lm -> return (lm <> listLMap)
-
-listLMap :: LogicMap -- TODO-REBARE: move to wiredIn
-listLMap = toLogicMap [ (dummyLoc nilName , [] , hNil)
- , (dummyLoc consName, [x, xs], hCons (EVar <$> [x, xs])) ]
- where
- x = "x"
- xs = "xs"
- hNil = mkEApp (dcSym Ghc.nilDataCon ) []
- hCons = mkEApp (dcSym Ghc.consDataCon)
- dcSym = dummyLoc . dropModuleUnique . symbol
-
-
-
---------------------------------------------------------------------------------
--- | Pretty Printing -----------------------------------------------------------
---------------------------------------------------------------------------------
-
-instance PPrint TargetSpec where
- pprintTidy k spec = vcat
- [ "******* Target Variables ********************"
- , pprintTidy k $ gsTgtVars (gsVars spec)
- , "******* Type Signatures *********************"
- , pprintLongList k (gsTySigs (gsSig spec))
- , "******* Assumed Type Signatures *************"
- , pprintLongList k (gsAsmSigs (gsSig spec))
- , "******* DataCon Specifications (Measure) ****"
- , pprintLongList k (gsCtors (gsData spec))
- , "******* Measure Specifications **************"
- , pprintLongList k (gsMeas (gsData spec)) ]
-
-instance PPrint TargetInfo where
- pprintTidy k info = vcat
- [ -- "*************** Imports *********************"
- -- , intersperse comma $ text <$> imports info
- -- , "*************** Includes ********************"
- -- , intersperse comma $ text <$> includes info
- "*************** Imported Variables **********"
- , pprDoc $ _giImpVars (review targetSrcIso $ giSrc info)
- , "*************** Defined Variables ***********"
- , pprDoc $ _giDefVars (review targetSrcIso $ giSrc info)
- , "*************** Specification ***************"
- , pprintTidy k $ giSpec info
- , "*************** Core Bindings ***************"
- , pprintCBs $ _giCbs (review targetSrcIso $ giSrc info) ]
-
--- RJ: the silly guards below are to silence the unused-var checker
-pprintCBs :: [CoreBind] -> Doc
-pprintCBs
- | otherwise = pprintCBsTidy
- | otherwise = pprintCBsVerbose
- where
- pprintCBsTidy = pprDoc . tidyCBs
- pprintCBsVerbose = text . O.showSDocDebug unsafeGlobalDynFlags . O.ppr . tidyCBs
-
-instance Show TargetInfo where
- show = showpp
-
-instance PPrint TargetVars where
- pprintTidy _ AllVars = text "All Variables"
- pprintTidy k (Only vs) = text "Only Variables: " <+> pprintTidy k vs
-
-------------------------------------------------------------------------
--- Dealing with Errors ---------------------------------------------------
-------------------------------------------------------------------------
-
-instance Result SourceError where
- result = (`Crash` "Invalid Source") . sourceErrors ""
diff --git a/src/Language/Haskell/Liquid/GHC/Logging.hs b/src/Language/Haskell/Liquid/GHC/Logging.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/GHC/Logging.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-{- | This module exposes variations over the standard GHC's logging functions to work with the 'Doc'
- type from the \"pretty\" package. We would like LiquidHaskell to emit diagnostic messages using the very
- same GHC machinery, so that IDE-like programs (e.g. \"ghcid\", \"ghcide\" etc) would be able to
- correctly show errors and warnings to the users, in ther editors.
-
- Unfortunately, this is not possible to do out of the box because LiquidHaskell uses the 'Doc' type from
- the \"pretty\" package but GHC uses (for historical reasons) its own version. Due to the fact none of
- the constructors are exported, we simply cannot convert between the two types effortlessly, but we have
- to pay the price of a pretty-printing \"roundtrip\".
--}
-
-module Language.Haskell.Liquid.GHC.Logging (
- fromPJDoc
- , putLogMsg
- , putWarnMsg
- , putErrMsg
- , putErrMsg'
- , mkLongErrAt
- ) where
-
-import Data.Maybe
-
-import qualified TcRnMonad as GHC
-
-import qualified Language.Haskell.Liquid.GHC.API as GHC
-import qualified Text.PrettyPrint.HughesPJ as PJ
-import qualified Outputable as O
-
--- Unfortunately we need the import below to bring in scope 'PPrint' instances.
-import Language.Haskell.Liquid.Types.Errors ()
-
-fromPJDoc :: PJ.Doc -> O.SDoc
-fromPJDoc = O.text . PJ.render
-
--- | Like the original 'putLogMsg', but internally converts the input 'Doc' (from the \"pretty\" library)
--- into GHC's internal 'SDoc'.
-putLogMsg :: GHC.DynFlags
- -> GHC.WarnReason
- -> GHC.Severity
- -> GHC.SrcSpan
- -> Maybe O.PprStyle
- -> PJ.Doc
- -> IO ()
-putLogMsg dynFlags reason sev srcSpan mbStyle =
- GHC.putLogMsg dynFlags reason sev srcSpan style' . O.text . PJ.render
- where
- style' :: O.PprStyle
- style' = fromMaybe (O.defaultErrStyle dynFlags) mbStyle
-
-putWarnMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()
-putWarnMsg dynFlags srcSpan doc =
- putLogMsg dynFlags GHC.NoReason GHC.SevWarning srcSpan (Just $ O.defaultErrStyle dynFlags) doc
-
-putErrMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()
-putErrMsg dynFlags srcSpan doc = putLogMsg dynFlags GHC.NoReason GHC.SevError srcSpan Nothing doc
-
--- | Like 'putErrMsg', but it uses GHC's internal 'Doc'. This can be very convenient when logging things
--- which comes directly from GHC rather than LiquidHaskell.
-putErrMsg' :: GHC.DynFlags -> GHC.SrcSpan -> O.SDoc -> IO ()
-putErrMsg' dynFlags srcSpan =
- GHC.putLogMsg dynFlags GHC.NoReason GHC.SevError srcSpan (O.defaultErrStyle dynFlags)
-
--- | Like GHC's 'mkLongErrAt', but it builds the final 'ErrMsg' out of two \"HughesPJ\"'s 'Doc's.
-mkLongErrAt :: GHC.SrcSpan -> PJ.Doc -> PJ.Doc -> GHC.TcRn GHC.ErrMsg
-mkLongErrAt srcSpan msg extra = GHC.mkLongErrAt srcSpan (fromPJDoc msg) (fromPJDoc extra)
diff --git a/src/Language/Haskell/Liquid/GHC/Misc.hs b/src/Language/Haskell/Liquid/GHC/Misc.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/GHC/Misc.hs
+++ /dev/null
@@ -1,781 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PatternSynonyms #-}
-
--- | This module contains a wrappers and utility functions for
--- accessing GHC module information. It should NEVER depend on
--- ANY module inside the Language.Haskell.Liquid.* tree.
-
-module Language.Haskell.Liquid.GHC.Misc where
-
-import Data.String
-import qualified Data.List as L
-import PrelNames (fractionalClassKeys)
-import Debug.Trace
-
-import qualified CoreUtils
-import qualified DataCon -- (dataConInstArgTys, isTupleDataCon)
-import Prelude hiding (error)
-import CoreSyn hiding (Expr, sourceName)
-import qualified CoreSyn as Core
-import CostCentre
-import Language.Haskell.Liquid.GHC.API as Ghc hiding (L, sourceName)
-import Bag
-import CoreLint
-import CoreMonad
-
-import Text.Parsec.Pos (incSourceColumn, sourceName, sourceLine, sourceColumn, newPos)
-
-import Finder (findImportedModule, cannotFindModule)
-import Panic (throwGhcException)
-import TcRnDriver
--- import TcRnTypes
-
-
-import IdInfo
-import qualified TyCon as TC
-import Data.Char (isLower, isSpace, isUpper)
-import Data.Maybe (isJust, fromMaybe, fromJust)
-import Data.Hashable
-import qualified Data.HashSet as S
-
-import qualified Data.Text.Encoding.Error as TE
-import qualified Data.Text.Encoding as T
-import qualified Data.Text as T
-import Control.Arrow (second)
-import Control.Monad ((>=>))
-import Outputable (Outputable (..), text, ppr)
-import qualified Outputable as Out
-import qualified Text.PrettyPrint.HughesPJ as PJ
-import Language.Fixpoint.Types hiding (L, panic, Loc (..), SrcSpan, Constant, SESearch (..))
-import qualified Language.Fixpoint.Types as F
-import Language.Fixpoint.Misc (safeHead) -- , safeLast, safeInit)
-import Language.Haskell.Liquid.Misc (keyDiff)
-import Control.DeepSeq
-import Language.Haskell.Liquid.Types.Errors
-
-
-isAnonBinder :: TC.TyConBinder -> Bool
-isAnonBinder (Bndr _ (AnonTCB _)) = True
-isAnonBinder (Bndr _ _) = False
-
-mkAlive :: Var -> Id
-mkAlive x
- | isId x && isDeadOcc (idOccInfo x)
- = setIdInfo x (setOccInfo (idInfo x) noOccInfo)
- | otherwise
- = x
-
-
---------------------------------------------------------------------------------
--- | Encoding and Decoding Location --------------------------------------------
---------------------------------------------------------------------------------
-srcSpanTick :: Module -> SrcSpan -> Tickish a
-srcSpanTick m sp = ProfNote (AllCafsCC m sp) False True
-
-tickSrcSpan :: Outputable a => Tickish a -> SrcSpan
-tickSrcSpan (ProfNote cc _ _) = cc_loc cc
-tickSrcSpan (SourceNote ss _) = RealSrcSpan ss
-tickSrcSpan _ = noSrcSpan
-
---------------------------------------------------------------------------------
--- | Generic Helpers for Accessing GHC Innards ---------------------------------
---------------------------------------------------------------------------------
-
--- FIXME: reusing uniques like this is really dangerous
-stringTyVar :: String -> TyVar
-stringTyVar s = mkTyVar name liftedTypeKind
- where
- name = mkInternalName (mkUnique 'x' 24) occ noSrcSpan
- occ = mkTyVarOcc s
-
--- FIXME: reusing uniques like this is really dangerous
-stringVar :: String -> Type -> Var
-stringVar s t = mkLocalVar VanillaId name t vanillaIdInfo
- where
- name = mkInternalName (mkUnique 'x' 25) occ noSrcSpan
- occ = mkVarOcc s
-
-stringTyCon :: Char -> Int -> String -> TyCon
-stringTyCon = stringTyConWithKind anyTy
-
--- FIXME: reusing uniques like this is really dangerous
-stringTyConWithKind :: Kind -> Char -> Int -> String -> TyCon
-stringTyConWithKind k c n s = TC.mkKindTyCon name [] k [] name
- where
- name = mkInternalName (mkUnique c n) occ noSrcSpan
- occ = mkTcOcc s
-
-hasBaseTypeVar :: Var -> Bool
-hasBaseTypeVar = isBaseType . varType
-
--- same as Constraint isBase
-isBaseType :: Type -> Bool
-isBaseType (ForAllTy _ _) = False
-isBaseType (FunTy { ft_arg = t1, ft_res = t2}) = isBaseType t1 && isBaseType t2
-isBaseType (TyVarTy _) = True
-isBaseType (TyConApp _ ts) = all isBaseType ts
-isBaseType (AppTy t1 t2) = isBaseType t1 && isBaseType t2
-isBaseType _ = False
-
-isTmpVar :: Var -> Bool
-isTmpVar = isTmpSymbol . dropModuleNamesAndUnique . symbol
-
-isTmpSymbol :: Symbol -> Bool
-isTmpSymbol x = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"]
-
-validTyVar :: String -> Bool
-validTyVar s@(c:_) = isLower c && all (not . isSpace) s
-validTyVar _ = False
-
-tvId :: TyVar -> String
-tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α)
-
-tidyCBs :: [CoreBind] -> [CoreBind]
-tidyCBs = map unTick
-
-unTick :: CoreBind -> CoreBind
-unTick (NonRec b e) = NonRec b (unTickExpr e)
-unTick (Rec bs) = Rec $ map (second unTickExpr) bs
-
-unTickExpr :: CoreExpr -> CoreExpr
-unTickExpr (App e a) = App (unTickExpr e) (unTickExpr a)
-unTickExpr (Lam b e) = Lam b (unTickExpr e)
-unTickExpr (Let b e) = Let (unTick b) (unTickExpr e)
-unTickExpr (Case e b t as) = Case (unTickExpr e) b t (map unTickAlt as)
- where unTickAlt (a, b, e) = (a, b, unTickExpr e)
-unTickExpr (Cast e c) = Cast (unTickExpr e) c
-unTickExpr (Tick _ e) = unTickExpr e
-unTickExpr x = x
-
-isFractionalClass :: Class -> Bool
-isFractionalClass clas = classKey clas `elem` fractionalClassKeys
-
---------------------------------------------------------------------------------
--- | Pretty Printers -----------------------------------------------------------
---------------------------------------------------------------------------------
-notracePpr :: Outputable a => String -> a -> a
-notracePpr _ x = x
-
-tracePpr :: Outputable a => String -> a -> a
-tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x
-
-pprShow :: Show a => a -> Out.SDoc
-pprShow = text . show
-
-
-toFixSDoc :: Fixpoint a => a -> PJ.Doc
-toFixSDoc = PJ.text . PJ.render . toFix
-
-sDocDoc :: Out.SDoc -> PJ.Doc
-sDocDoc = PJ.text . showSDoc
-
-pprDoc :: Outputable a => a -> PJ.Doc
-pprDoc = sDocDoc . ppr
-
--- Overriding Outputable functions because they now require DynFlags!
-showPpr :: Outputable a => a -> String
-showPpr = showSDoc . ppr
-
--- FIXME: somewhere we depend on this printing out all GHC entities with
--- fully-qualified names...
-showSDoc :: Out.SDoc -> String
-showSDoc sdoc = Out.renderWithStyle unsafeGlobalDynFlags sdoc (Out.mkUserStyle unsafeGlobalDynFlags myQualify {- Out.alwaysQualify -} Out.AllTheWay)
-
-myQualify :: Out.PrintUnqualified
-myQualify = Out.neverQualify { Out.queryQualifyName = Out.alwaysQualifyNames }
--- { Out.queryQualifyName = \_ _ -> Out.NameNotInScope1 }
-
-showSDocDump :: Out.SDoc -> String
-showSDocDump = Out.showSDocDump unsafeGlobalDynFlags
-
-instance Outputable a => Outputable (S.HashSet a) where
- ppr = ppr . S.toList
-
-typeUniqueString :: Outputable a => a -> String
-typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr
-
-
---------------------------------------------------------------------------------
--- | Manipulating Source Spans -------------------------------------------------
---------------------------------------------------------------------------------
-
-newtype Loc = L (Int, Int) deriving (Eq, Ord, Show)
-
-instance Hashable Loc where
- hashWithSalt i (L z) = hashWithSalt i z
-
---instance (Uniquable a) => Hashable a where
-
-instance Hashable SrcSpan where
- hashWithSalt i (UnhelpfulSpan s) = hashWithSalt i (uniq s)
- hashWithSalt i (RealSrcSpan s) = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s)
-
-fSrcSpan :: (F.Loc a) => a -> SrcSpan
-fSrcSpan = fSrcSpanSrcSpan . F.srcSpan
-
-fSourcePos :: (F.Loc a) => a -> F.SourcePos
-fSourcePos = F.sp_start . F.srcSpan
-
-fSrcSpanSrcSpan :: F.SrcSpan -> SrcSpan
-fSrcSpanSrcSpan (F.SS p p') = sourcePos2SrcSpan p p'
-
-srcSpanFSrcSpan :: SrcSpan -> F.SrcSpan
-srcSpanFSrcSpan sp = F.SS p p'
- where
- p = srcSpanSourcePos sp
- p' = srcSpanSourcePosE sp
-
-sourcePos2SrcSpan :: SourcePos -> SourcePos -> SrcSpan
-sourcePos2SrcSpan p p' = RealSrcSpan $ realSrcSpan f l c l' c'
- where
- (f, l, c) = F.sourcePosElts p
- (_, l', c') = F.sourcePosElts p'
-
-sourcePosSrcSpan :: SourcePos -> SrcSpan
-sourcePosSrcSpan p = sourcePos2SrcSpan p (incSourceColumn p 1)
-
-sourcePosSrcLoc :: SourcePos -> SrcLoc
-sourcePosSrcLoc p = mkSrcLoc (fsLit file) line col
- where
- file = sourceName p
- line = sourceLine p
- col = sourceColumn p
-
-srcSpanSourcePos :: SrcSpan -> SourcePos
-srcSpanSourcePos (UnhelpfulSpan _) = dummyPos " Blob a ===> {v:Field Blob a | q v}
-
- which is NOT ok, because q expects a different arg.
-
- The above happens because, thanks to instance-family stuff,
- LH doesn't realize that q is actually an ARG of Field Blob
- Note that Field itself has no args, but Field Blob does...
-
- That is, it is not enough to store the refined `TyCon` info,
- solely in the `RTyCon` as with family instances, you need BOTH
- the `TyCon` and the args to determine the extra info.
-
- We do so in `TyConMap`, and by crucially extending
-
- @RefType.appRTyCon@ whose job is to use the Refined @TyCon@
- that is, the @RTyCon@ generated from the @TyConP@ to strengthen
- individual occurrences of the TyCon applied to various arguments.
-
- -}
-
-appRTyCon :: (ToTypeable r) => TCEmb TyCon -> TyConMap -> RTyCon -> [RRType r] -> (RTyCon, [RPVar])
-appRTyCon tce tyi rc ts = F.notracepp _msg (resTc, ps'')
- where
- _msg = "appRTyCon-family: " ++ showpp (Ghc.isFamilyTyCon c, Ghc.tyConRealArity c, toType <$> ts)
- resTc = RTyCon c ps'' (rtc_info rc'')
- c = rtc_tc rc
-
- (rc', ps') = rTyConWithPVars tyi rc (rTypeSort tce <$> ts)
- -- TODO:faminst-preds rc' = M.lookupDefault rc c (tcmTyRTy tyi)
- -- TODO:faminst-preds ps' = rTyConPVs rc'
-
- -- TODO:faminst-preds: these substitutions may be WRONG if we are using FAMINST.
- ps'' = subts (zip (RTV <$> αs) ts') <$> ps'
- where
- ts' = if null ts then rVar <$> βs else toRSort <$> ts
- αs = GM.tyConTyVarsDef (rtc_tc rc')
- βs = GM.tyConTyVarsDef c
-
- rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc'
-
-rTyConWithPVars :: TyConMap -> RTyCon -> [F.Sort] -> (RTyCon, [RPVar])
-rTyConWithPVars tyi rc ts = case famInstTyConMb tyi rc ts of
- Just fiRc -> (rc', rTyConPVs fiRc) -- use the PVars from the family-instance TyCon
- Nothing -> (rc', ps') -- use the PVars from the origin TyCon
- where
- (rc', ps') = plainRTyConPVars tyi rc
-
--- | @famInstTyConMb rc args@ uses the @RTyCon@ AND @args@ to see if
--- this is a family instance @RTyCon@, and if so, returns it.
--- see [NOTE:FamInstPredVars]
--- eg: 'famInstTyConMb tyi Field [Blob, a]' should give 'Just R:FieldBlob'
-
-famInstTyConMb :: TyConMap -> RTyCon -> [F.Sort] -> Maybe RTyCon
-famInstTyConMb tyi rc ts = do
- let c = rtc_tc rc
- n <- M.lookup c (tcmFtcArity tyi)
- M.lookup (c, take n ts) (tcmFIRTy tyi)
-
-famInstTyConType :: Ghc.TyCon -> Maybe Ghc.Type
-famInstTyConType c = uncurry Ghc.mkTyConApp <$> famInstArgs c
-
--- | @famInstArgs c@ destructs a family-instance @TyCon@ into its components, e.g.
--- e.g. 'famInstArgs R:FieldBlob' is @(Field, [Blob])@
-
-famInstArgs :: Ghc.TyCon -> Maybe (Ghc.TyCon, [Ghc.Type])
-famInstArgs c = case Ghc.tyConFamInst_maybe c of
- Just (c', ts) -> F.notracepp ("famInstArgs: " ++ F.showpp (c, cArity, ts))
- $ Just (c', take (length ts - cArity) ts)
- Nothing -> Nothing
- where
- cArity = Ghc.tyConRealArity 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 (famInstType (Ghc.tyConArity c) c' ts)
--- TODO:faminst-preds: Nothing -> Nothing
-
--- TODO:faminst-preds: famInstType :: Int -> Ghc.TyCon -> [Ghc.Type] -> Ghc.Type
--- TODO:faminst-preds: famInstType n c ts = Ghc.mkTyConApp c (take (length ts - n) ts)
-
-
-
-
--- | @plainTyConPVars@ uses the @TyCon@ to return the
--- "refined" @RTyCon@ and @RPVars@ from the refined
--- 'data' definition for the @TyCon@, e.g. will use
--- 'List Int' to return 'List
-> a
"
- , "Put mouse over identifiers to see inferred types"
- ]
-
-htmlClose :: IsString a => a
-htmlClose = "\n\n"
-
-cssHTML :: String -> String
-cssHTML css = unlines
- [ ""
- , ""
- , ""
- ]
-
-------------------------------------------------------------------------------
--- | Building Annotation Maps ------------------------------------------------
-------------------------------------------------------------------------------
-
--- | This function converts our annotation information into that which
--- is required by `Language.Haskell.Liquid.ACSS` to generate mouseover
--- annotations.
-
-mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> ACSS.AnnMap
-mkAnnMap cfg res ann = ACSS.Ann
- { ACSS.types = mkAnnMapTyp cfg ann
- , ACSS.errors = mkAnnMapErr res
- , ACSS.status = mkStatus res
- , ACSS.sptypes = mkAnnMapBinders cfg ann
- }
-
-mkStatus :: FixResult t -> ACSS.Status
-mkStatus (Safe _) = ACSS.Safe
-mkStatus (Unsafe _ _) = ACSS.Unsafe
-mkStatus (Crash _ _) = ACSS.Error
-
-
-
-mkAnnMapErr :: PPrint (TError t)
- => FixResult (TError t) -> [(Loc, Loc, String)]
-mkAnnMapErr (Unsafe _ ls) = mapMaybe cinfoErr ls
-mkAnnMapErr (Crash ls _) = mapMaybe cinfoErr ls
-mkAnnMapErr _ = []
-
-cinfoErr :: PPrint (TError t) => TError t -> Maybe (Loc, Loc, String)
-cinfoErr e = case pos e of
- RealSrcSpan l -> Just (srcSpanStartLoc l, srcSpanEndLoc l, showpp e)
- _ -> Nothing
-
-
--- mkAnnMapTyp :: (RefTypable a c tv r, RefTypable a c tv (), PPrint tv, PPrint a) =>Config-> AnnInfo (RType a c tv r) -> M.HashMap Loc (String, String)
-mkAnnMapTyp :: Config -> AnnInfo Doc -> M.HashMap Loc (String, String)
-mkAnnMapTyp cfg z = M.fromList $ map (first srcSpanStartLoc) $ mkAnnMapBinders cfg z
-
-mkAnnMapBinders :: Config -> AnnInfo Doc -> [(SrcLoc.RealSrcSpan, (String, String))]
-mkAnnMapBinders cfg (AI m)
- = map (second bindStr . head . sortWith (srcSpanEndCol . fst))
- $ groupWith (lineCol . fst) locBinds
- where
- locBinds = [ (l, x) | (RealSrcSpan l, x:_) <- M.toList m, oneLine l]
- bindStr (x, v) = (maybe "_" (symbolString . shorten . symbol) x, render v)
- shorten = if shortNames cfg then dropModuleNames else id
-
-closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType
-closeAnnots = closeA . filterA . collapseA
-
-closeA :: AnnInfo (Annot b) -> AnnInfo b
-closeA a@(AI m) = cf <$> a
- where
- cf (AnnLoc l) = case m `mlookup` l of
- [(_, AnnUse t)] -> t
- [(_, AnnDef t)] -> t
- [(_, AnnRDf t)] -> t
- _ -> panic Nothing $ "malformed AnnInfo: " ++ showPpr l
- cf (AnnUse t) = t
- cf (AnnDef t) = t
- cf (AnnRDf t) = t
-
-filterA :: AnnInfo (Annot t) -> AnnInfo (Annot t)
-filterA (AI m) = AI (M.filter ff m)
- where
- ff [(_, AnnLoc l)] = l `M.member` m
- ff _ = True
-
-collapseA :: AnnInfo (Annot t) -> AnnInfo (Annot t)
-collapseA (AI m) = AI (fmap pickOneA m)
-
-pickOneA :: [(t, Annot t1)] -> [(t, Annot t1)]
-pickOneA xas = case (rs, ds, ls, us) of
- (x:_, _, _, _) -> [x]
- (_, x:_, _, _) -> [x]
- (_, _, x:_, _) -> [x]
- (_, _, _, x:_) -> [x]
- (_, _, _, _ ) -> [ ]
- where
- rs = [x | x@(_, AnnRDf _) <- xas]
- ds = [x | x@(_, AnnDef _) <- xas]
- ls = [x | x@(_, AnnLoc _) <- xas]
- us = [x | x@(_, AnnUse _) <- xas]
-
-------------------------------------------------------------------------------
--- | Tokenizing Refinement Type Annotations in @-blocks ----------------------
-------------------------------------------------------------------------------
-
--- | The token used for refinement symbols inside the highlighted types in @-blocks.
-refToken :: TokenType
-refToken = Keyword
-
--- | The top-level function for tokenizing @-block annotations. Used to
--- tokenize comments by ACSS.
-tokAnnot :: String -> [(TokenType, String)]
-tokAnnot s
- = case trimLiquidAnnot s of
- Just (l, body, r) -> [(refToken, l)] ++ tokBody body ++ [(refToken, r)]
- Nothing -> [(Comment, s)]
-
-trimLiquidAnnot :: String -> Maybe (String, String, String)
-trimLiquidAnnot ('{':'-':'@':ss)
- | drop (length ss - 3) ss == "@-}"
- = Just (liquidBegin, take (length ss - 3) ss, liquidEnd)
-trimLiquidAnnot _
- = Nothing
-
-tokBody :: String -> [(TokenType, String)]
-tokBody s
- | isData s = tokenise s
- | isType s = tokenise s
- | isIncl s = tokenise s
- | isMeas s = tokenise s
- | otherwise = tokeniseSpec s
-
-isMeas :: String -> Bool
-isMeas = spacePrefix "measure"
-
-isData :: String -> Bool
-isData = spacePrefix "data"
-
-isType :: String -> Bool
-isType = spacePrefix "type"
-
-isIncl :: String -> Bool
-isIncl = spacePrefix "include"
-
-{-@ spacePrefix :: String -> s:String -> Bool / [len s] @-}
-spacePrefix :: String -> String -> Bool
-spacePrefix str s@(c:cs)
- | isSpace c = spacePrefix str cs
- | otherwise = take (length str) s == str
-spacePrefix _ _ = False
-
-
-tokeniseSpec :: String -> [(TokenType, String)]
-tokeniseSpec = tokAlt . chopAltDBG
- where
- tokAlt (s:ss) = tokenise s ++ tokAlt' ss
- tokAlt _ = []
- tokAlt' (s:ss) = (refToken, s) : tokAlt ss
- tokAlt' _ = []
-
-chopAltDBG :: String -> [String]
-chopAltDBG y = filter (/= "")
- $ concatMap (chopAlts [("{", ":"), ("|", "}")])
- $ chopAlts [("<{", "}>"), ("{", "}")] y
-
-
-------------------------------------------------------------------------
--- | JSON: Annotation Data Types ---------------------------------------
-------------------------------------------------------------------------
-
-data Assoc k a = Asc (M.HashMap k a)
-type AnnTypes = Assoc Int (Assoc Int Annot1)
-newtype AnnErrors = AnnErrors [(Loc, Loc, String)]
-data Annot1 = A1 { ident :: String
- , ann :: String
- , row :: Int
- , col :: Int
- }
-
-------------------------------------------------------------------------
--- | Creating Vim Annotations ------------------------------------------
-------------------------------------------------------------------------
-vimAnnot :: Config -> AnnInfo Doc -> String
-vimAnnot cfg = L.intercalate "\n" . map vimBind . mkAnnMapBinders cfg
-
-vimBind :: (Show a, PrintfType t) => (SrcLoc.RealSrcSpan, (String, a)) -> t
-vimBind (sp, (v, ann)) = printf "%d:%d-%d:%d::%s" l1 c1 l2 c2 (v ++ " :: " ++ show ann)
- where
- l1 = srcSpanStartLine sp
- c1 = srcSpanStartCol sp
- l2 = srcSpanEndLine sp
- c2 = srcSpanEndCol sp
-
-------------------------------------------------------------------------
--- | JSON Instances ----------------------------------------------------
-------------------------------------------------------------------------
-
-instance ToJSON ACSS.Status where
- toJSON ACSS.Safe = "safe"
- toJSON ACSS.Unsafe = "unsafe"
- toJSON ACSS.Error = "error"
- toJSON ACSS.Crash = "crash"
-
-instance ToJSON Annot1 where
- toJSON (A1 i a r c) = object [ "ident" .= i
- , "ann" .= a
- , "row" .= r
- , "col" .= c
- ]
-
-instance ToJSON Loc where
- toJSON (L (l, c)) = object [ "line" .= toJSON l
- , "column" .= toJSON c ]
-
-instance ToJSON AnnErrors where
- toJSON (AnnErrors errs) = Array $ V.fromList (toJ <$> errs)
- where
- toJ (l,l',s) = object [ "start" .= toJSON l
- , "stop" .= toJSON l'
- , "message" .= toJSON (dropErrorLoc s)
- ]
-
-
-
-
-dropErrorLoc :: String -> String
-dropErrorLoc msg
- | null msg' = msg
- | otherwise = tail msg'
- where
- (_, msg') = break (' ' ==) msg
-
-instance (Show k, ToJSON a) => ToJSON (Assoc k a) where
- toJSON (Asc kas) = object [ tshow k .= toJSON a | (k, a) <- M.toList kas ]
- where
- tshow = T.pack . show
-
-instance ToJSON ACSS.AnnMap where
- toJSON a = object [ "types" .= toJSON (annTypes a)
- , "errors" .= toJSON (annErrors a)
- , "status" .= toJSON (ACSS.status a)
- , "sptypes" .= (toJ <$> ACSS.sptypes a)
- ]
- where
- toJ (sp, (x,t)) = object [ "start" .= toJSON (srcSpanStartLoc sp)
- , "stop" .= toJSON (srcSpanEndLoc sp)
- , "ident" .= toJSON x
- , "ann" .= toJSON t
- ]
-
-annErrors :: ACSS.AnnMap -> AnnErrors
-annErrors = AnnErrors . ACSS.errors
-
-annTypes :: ACSS.AnnMap -> AnnTypes
-annTypes a = grp [(l, c, ann1 l c x s) | (l, c, x, s) <- binders]
- where
- ann1 l c x s = A1 x s l c
- grp = L.foldl' (\m (r,c,x) -> ins r c x m) (Asc M.empty)
- binders = [(l, c, x, s) | (L (l, c), (x, s)) <- M.toList $ ACSS.types a]
-
-ins :: (Eq k, Eq k1, Hashable k, Hashable k1)
- => k -> k1 -> a -> Assoc k (Assoc k1 a) -> Assoc k (Assoc k1 a)
-ins r c x (Asc m) = Asc (M.insert r (Asc (M.insert c x rm)) m)
- where
- Asc rm = M.lookupDefault (Asc M.empty) r m
-
-tokeniseWithLoc :: String -> [(TokenType, String, Loc)]
-tokeniseWithLoc = ACSS.tokeniseWithLoc (Just tokAnnot)
-
---------------------------------------------------------------------------------
--- | LH Related Stuff ----------------------------------------------------------
---------------------------------------------------------------------------------
-
-{-@ LIQUID "--diffcheck" @-}
-
-{-@ type ListNE a = {v:[a] | 0 < len v} @-}
-{-@ type ListN a N = {v:[a] | len v == N} @-}
-{-@ type ListXs a Xs = ListN a {len Xs} @-}
-
-{-@ assume GHC.Exts.sortWith :: Ord b => (a -> b) -> xs:[a] -> ListXs a xs @-}
-{-@ assume GHC.Exts.groupWith :: Ord b => (a -> b) -> [a] -> [ListNE a] @-}
-
---------------------------------------------------------------------------------
--- | A Little Unit Test --------------------------------------------------------
---------------------------------------------------------------------------------
-
-_anns :: AnnTypes
-_anns = i [(5, i [( 14, A1 { ident = "foo"
- , ann = "int -> int"
- , row = 5
- , col = 14
- })
- ]
- )
- ,(9, i [( 22, A1 { ident = "map"
- , ann = "(a -> b) -> [a] -> [b]"
- , row = 9
- , col = 22
- })
- ,( 28, A1 { ident = "xs"
- , ann = "[b]"
- , row = 9
- , col = 28
- })
- ])
- ]
-
-i :: (Eq k, Hashable k) => [(k, a)] -> Assoc k a
-i = Asc . M.fromList
diff --git a/src/Language/Haskell/Liquid/UX/CTags.hs b/src/Language/Haskell/Liquid/UX/CTags.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/UX/CTags.hs
+++ /dev/null
@@ -1,77 +0,0 @@
--- | This module contains the code for generating "tags" for constraints
--- based on their source, i.e. the top-level binders under which the
--- constraint was generated. These tags are used by fixpoint to
--- prioritize constraints by the "source-level" function.
-
-{-# LANGUAGE TupleSections #-}
-
-module Language.Haskell.Liquid.UX.CTags (
- -- * Type for constraint tags
- TagKey, TagEnv
-
- -- * Default tag value
- , defaultTag
-
- -- * Constructing @TagEnv@
- , makeTagEnv
-
- -- * Accessing @TagEnv@
- , getTag
- , memTagEnv
-
-) where
-
-import Var
-import CoreSyn
-import Prelude hiding (error)
-
-import qualified Data.HashSet as S
-import qualified Data.HashMap.Strict as M
-import qualified Data.Graph as G
-
-import Language.Fixpoint.Types (Tag)
-import Language.Haskell.Liquid.Types.Visitors (freeVars)
-import Language.Haskell.Liquid.Types.PrettyPrint ()
-import Language.Fixpoint.Misc (mapSnd)
-
--- | The @TagKey@ is the top-level binder, and @Tag@ is a singleton Int list
-
-type TagKey = Var
-type TagEnv = M.HashMap TagKey Tag
-
--- TODO: use the "callgraph" SCC to do this numbering.
-
-defaultTag :: Tag
-defaultTag = [0]
-
-memTagEnv :: TagKey -> TagEnv -> Bool
-memTagEnv = M.member
-
-makeTagEnv :: [CoreBind] -> TagEnv
-makeTagEnv = {- tracepp "TAGENV" . -} M.map (:[]) . callGraphRanks . makeCallGraph
-
--- makeTagEnv = M.fromList . (`zip` (map (:[]) [1..])). L.sort . map fst . concatMap bindEqns
-
-getTag :: TagKey -> TagEnv -> Tag
-getTag = M.lookupDefault defaultTag
-
-------------------------------------------------------------------------------------------------------
-
-type CallGraph = [(Var, [Var])] -- caller-callee pairs
-
-callGraphRanks :: CallGraph -> M.HashMap Var Int
--- callGraphRanks cg = traceShow ("CallGraph Ranks: " ++ show cg) $ callGraphRanks' cg
-
-callGraphRanks = M.fromList . concat . index . mkScc
- where mkScc cg = G.stronglyConnComp [(u, u, vs) | (u, vs) <- cg]
- index = zipWith (\i -> map (, i) . G.flattenSCC) [1..]
-
-makeCallGraph :: [CoreBind] -> CallGraph
-makeCallGraph cbs = mapSnd calls `fmap` xes
- where xes = concatMap bindEqns cbs
- xs = S.fromList $ map fst xes
- calls = filter (`S.member` xs) . freeVars S.empty
-
-bindEqns :: Bind t -> [(t, Expr t)]
-bindEqns (NonRec x e) = [(x, e)]
-bindEqns (Rec xes) = xes
diff --git a/src/Language/Haskell/Liquid/UX/CmdLine.hs b/src/Language/Haskell/Liquid/UX/CmdLine.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/UX/CmdLine.hs
+++ /dev/null
@@ -1,769 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-cse #-}
-
--- | This module contains all the code needed to output the result which
--- is either: `SAFE` or `WARNING` with some reasonable error message when
--- something goes wrong. All forms of errors/exceptions should go through
--- here. The idea should be to report the error, the source position that
--- causes it, generate a suitable .json file and then exit.
-
-module Language.Haskell.Liquid.UX.CmdLine (
- -- * Get Command Line Configuration
- getOpts, mkOpts, defConfig, config
-
- -- * Update Configuration With Pragma
- , withPragmas
-
- -- * Canonicalize Paths in Config
- , canonicalizePaths
-
- -- * Exit Function
- , exitWithResult
- , addErrors
-
- -- * Reporting the output of the checking
- , OutputResult(..)
- , reportResult
-
- -- * Diff check mode
- , diffcheck
-
- -- * Show info about this version of LiquidHaskell
- , printLiquidHaskellBanner
-
-) where
-
-import Prelude hiding (error)
-
-
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Maybe
-import Data.Aeson (encode)
-import qualified Data.ByteString.Lazy.Char8 as B
-import Development.GitRev (gitCommitCount)
-import Options.Applicative.Simple (simpleVersion)
-import qualified Paths_liquidhaskell as Meta
-import System.Directory
-import System.Exit
-import System.Environment
-import System.Console.CmdArgs.Explicit
-import System.Console.CmdArgs.Implicit hiding (Loud)
-import qualified System.Console.CmdArgs.Verbosity as CmdArgs
-import System.Console.CmdArgs.Text
-import GitHash
-
-import Data.List (nub)
-
-
-import System.FilePath (isAbsolute, takeDirectory, ())
-
-import qualified Language.Fixpoint.Types.Config as FC
-import Language.Fixpoint.Misc
-import Language.Fixpoint.Types.Names
-import Language.Fixpoint.Types hiding (panic, Error, Result, saveQuery)
-import qualified Language.Fixpoint.Types as F
-import Language.Fixpoint.Solver.Stats as Solver
-import Language.Haskell.Liquid.UX.Annotate
-import Language.Haskell.Liquid.UX.Config
-import Language.Haskell.Liquid.GHC.Misc
-import Language.Haskell.Liquid.Misc
-import Language.Haskell.Liquid.Types.PrettyPrint ()
-import Language.Haskell.Liquid.Types hiding (typ)
-import qualified Language.Haskell.Liquid.UX.ACSS as ACSS
-
-import qualified Language.Haskell.Liquid.GHC.API as GHC
-
-
-import Text.Parsec.Pos (newPos)
-import Text.PrettyPrint.HughesPJ hiding (Mode, (<>))
-
-
-
----------------------------------------------------------------------------------
--- Config Magic Numbers----------------------------------------------------------
----------------------------------------------------------------------------------
-
-defaultMaxParams :: Int
-defaultMaxParams = 2
-
----------------------------------------------------------------------------------
--- Parsing Command Line----------------------------------------------------------
----------------------------------------------------------------------------------
-config :: Mode (CmdArgs Config)
-config = cmdArgsMode $ Config {
- loggingVerbosity
- = enum [ Quiet &= name "quiet" &= help "Minimal logging verbosity"
- , Normal &= name "normal" &= help "Normal logging verbosity"
- , CmdArgs.Loud &= name "verbose" &= help "Verbose logging"
- ]
-
- , files
- = def &= typ "TARGET"
- &= args
- &= typFile
-
- , idirs
- = def &= typDir
- &= help "Paths to Spec Include Directory "
-
- , fullcheck
- = def
- &= help "Full Checking: check all binders (DEFAULT)"
-
- , diffcheck
- = def
- &= help "Incremental Checking: only check changed binders"
-
- , higherorder
- = def
- &= help "Allow higher order binders into the logic"
-
- , smtTimeout
- = def
- &= help "Timeout of smt queries in msec"
-
- , higherorderqs
- = def
- &= help "Allow higher order qualifiers to get automatically instantiated"
-
- , linear
- = def
- &= help "Use uninterpreted integer multiplication and division"
-
- , stringTheory
- = def
- &= help "Interpretation of Strings by z3"
-
- , saveQuery
- = def &= help "Save fixpoint query to file (slow)"
-
- , checks
- = def &= help "Check a specific (top-level) binder"
- &= name "check-var"
-
- , pruneUnsorted
- = def &= help "Disable prunning unsorted Predicates"
- &= name "prune-unsorted"
-
- , notermination
- = def
- &= help "Disable Termination Check"
- &= name "no-termination-check"
-
- , rankNTypes
- = def &= help "Adds precise reasoning on presence of rankNTypes"
- &= name "rankNTypes"
-
- , noclasscheck
- = def
- &= help "Disable Class Instance Check"
- &= name "no-class-check"
-
- , nostructuralterm
- = def &= name "no-structural-termination"
- &= help "Disable structural termination check"
-
- , gradual
- = def &= help "Enable gradual refinement type checking"
- &= name "gradual"
-
- , bscope
- = def &= help "scope of the outer binders on the inner refinements"
- &= name "bscope"
-
- , gdepth
- = 1
- &= help ("Size of gradual conretizations, 1 by default")
- &= name "gradual-depth"
-
- , ginteractive
- = def &= help "Interactive Gradual Solving"
- &= name "ginteractive"
-
- , totalHaskell
- = def &= help "Check for termination and totality; overrides no-termination flags"
- &= name "total-Haskell"
-
- , nowarnings
- = def &= help "Don't display warnings, only show errors"
- &= name "no-warnings"
-
- , noannotations
- = def &= help "Don't create intermediate annotation files"
- &= name "no-annotations"
-
- , checkDerived
- = def &= help "Check GHC generated binders (e.g. Read, Show instances)"
- &= name "check-derived"
-
- , caseExpandDepth
- = 2 &= help "Maximum depth at which to expand DEFAULT in case-of (default=2)"
- &= name "max-case-expand"
-
- , notruetypes
- = def &= help "Disable Trueing Top Level Types"
- &= name "no-true-types"
-
- , nototality
- = def &= help "Disable totality check"
- &= name "no-totality"
-
- , cores
- = def &= help "Use m cores to solve logical constraints"
-
- , minPartSize
- = FC.defaultMinPartSize
- &= help "If solving on multiple cores, ensure that partitions are of at least m size"
-
- , maxPartSize
- = FC.defaultMaxPartSize
- &= help ("If solving on multiple cores, once there are as many partitions " ++
- "as there are cores, don't merge partitions if they will exceed this " ++
- "size. Overrides the minpartsize option.")
-
- , smtsolver
- = def &= help "Name of SMT-Solver"
-
- , noCheckUnknown
- = def &= explicit
- &= name "no-check-unknown"
- &= help "Don't complain about specifications for unexported and unused values "
-
- , maxParams
- = defaultMaxParams &= help "Restrict qualifier mining to those taking at most `m' parameters (2 by default)"
-
- , shortNames
- = def &= name "short-names"
- &= help "Print shortened names, i.e. drop all module qualifiers."
-
- , shortErrors
- = def &= name "short-errors"
- &= help "Don't show long error messages, just line numbers."
-
- , cabalDir
- = def &= name "cabal-dir"
- &= help "Find and use .cabal to add paths to sources for imported files"
-
- , ghcOptions
- = def &= name "ghc-option"
- &= typ "OPTION"
- &= help "Pass this option to GHC"
-
- , cFiles
- = def &= name "c-files"
- &= typ "OPTION"
- &= help "Tell GHC to compile and link against these files"
-
- , port
- = defaultPort
- &= name "port"
- &= help "Port at which lhi should listen"
-
- , exactDC
- = def &= help "Exact Type for Data Constructors"
- &= name "exact-data-cons"
-
- , noADT
- = def &= help "Do not generate ADT representations in refinement logic"
- &= name "no-adt"
-
- , scrapeImports
- = False &= help "Scrape qualifiers from imported specifications"
- &= name "scrape-imports"
- &= explicit
-
- , scrapeInternals
- = False &= help "Scrape qualifiers from auto generated specifications"
- &= name "scrape-internals"
- &= explicit
-
- , scrapeUsedImports
- = False &= help "Scrape qualifiers from used, imported specifications"
- &= name "scrape-used-imports"
- &= explicit
-
- , elimStats
- = False &= name "elimStats"
- &= help "Print eliminate stats"
-
- , elimBound
- = Nothing
- &= name "elimBound"
- &= help "Maximum chain length for eliminating KVars"
-
- , noslice
- = False
- &= name "noSlice"
- &= help "Disable non-concrete KVar slicing"
-
- , noLiftedImport
- = False
- &= name "no-lifted-imports"
- &= help "Disable loading lifted specifications (for legacy libs)"
-
- , json
- = False &= name "json"
- &= help "Print results in JSON (for editor integration)"
-
- , counterExamples
- = False &= name "counter-examples"
- &= help "Attempt to generate counter-examples to type errors (experimental!)"
-
- , timeBinds
- = False &= name "time-binds"
- &= help "Solve each (top-level) asserted type signature separately & time solving."
-
- , untidyCore
- = False &= name "untidy-core"
- &= help "Print fully qualified identifier names in verbose mode"
-
- , eliminate
- = FC.Some
- &= name "eliminate"
- &= help "Use elimination for 'all' (use TRUE for cut-kvars), 'some' (use quals for cut-kvars) or 'none' (use quals for all kvars)."
-
- , noPatternInline
- = False &= name "no-pattern-inline"
- &= help "Don't inline special patterns (e.g. `>>=` and `return`) during constraint generation."
-
- , noSimplifyCore
- = False &= name "no-simplify-core"
- &= help "Don't simplify GHC core before constraint generation"
-
- -- PLE-OPT , autoInstantiate
- -- PLE-OPT = def
- -- PLE-OPT &= help "How to instantiate axiomatized functions `smtinstances` for SMT instantiation, `liquidinstances` for terminating instantiation"
- -- PLE-OPT &= name "automatic-instances"
-
- , proofLogicEval
- = def
- &= help "Enable Proof-by-Logical-Evaluation"
- &= name "ple"
-
- , oldPLE
- = def
- &= help "Enable Proof-by-Logical-Evaluation"
- &= name "oldple"
-
- , proofLogicEvalLocal
- = def
- &= help "Enable Proof-by-Logical-Evaluation locally, per function"
- &= name "ple-local"
-
- , extensionality
- = def
- &= help "Enable extensional interpretation of function equality"
- &= name "extensionality"
-
- , nopolyinfer
- = def
- &= help "No inference of polymorphic type application. Gives imprecision, but speedup."
- &= name "fast"
-
- , reflection
- = def
- &= help "Enable reflection of Haskell functions and theorem proving"
- &= name "reflection"
-
- , compileSpec
- = def
- &= name "compile-spec"
- &= help "Only compile specifications (into .bspec file); skip verification"
-
- , noCheckImports
- = def
- &= name "no-check-imports"
- &= help "Do not check the transitive imports; only check the target files."
-
- , typedHoles
- = def
- &= name "typed-holes"
- &= help "Use (refinement) typed-holes [currently warns on '_x' variables]"
- , maxMatchDepth
- = def
- &= name "max-match-depth"
- &= help "Define the number of expressions to pattern match on (typed-holes must be on to use this flag)."
- , maxAppDepth
- = def
- &= name "max-app-depth"
- , maxArgsDepth
- = def
- &= name "max-args-depth"
- ,
- maxRWOrderingConstraints
- = def
- &= name "max-rw-ordering-constraints"
- &= help ( "Maximium number of symbols to compare for rewrite termination. "
- ++ "Lower values can speedup verification, but rewriting may terminate prematurely. "
- ++ "Leave empty to consider all symbols." )
- ,
- rwTerminationCheck
- = def
- &= name "rw-termination-check"
- &= help ( "Enable the rewrite divergence checker. "
- ++ "Can speed up verification if rewriting terminates, but can also cause divergence."
- )
- } &= program "liquid"
- &= help "Refinement Types for Haskell"
- &= summary copyright
- &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell"
- , ""
- , "To check a Haskell file foo.hs, type:"
- , " liquid foo.hs "
- ]
-
-defaultPort :: Int
-defaultPort = 3000
-
-getOpts :: [String] -> IO Config
-getOpts as = do
- cfg0 <- envCfg
- cfg1 <- mkOpts =<< cmdArgsRun'
- config { modeValue = (modeValue config)
- { cmdArgsValue = cfg0
- }
- }
- as
- cfg <- fixConfig cfg1
- setVerbosity (loggingVerbosity cfg)
- when (json cfg) $ setVerbosity Quiet
- withSmtSolver cfg
-
--- | Shows the LiquidHaskell banner, that includes things like the copyright, the
--- git commit and the version.
-printLiquidHaskellBanner :: IO ()
-printLiquidHaskellBanner = whenNormal $ putStrLn copyright
-
-cmdArgsRun' :: Mode (CmdArgs a) -> [String] -> IO a
-cmdArgsRun' md as
- = case parseResult of
- Left e -> putStrLn (helpMsg e) >> exitFailure
- Right a -> cmdArgsApply a
- where
- helpMsg e = showText defaultWrap $ helpText [e] HelpFormatDefault md
- parseResult = process md (wideHelp as)
- wideHelp = map (\a -> if a == "--help" || a == "-help" then "--help=120" else a)
-
-
---------------------------------------------------------------------------------
-withSmtSolver :: Config -> IO Config
---------------------------------------------------------------------------------
-withSmtSolver cfg =
- case smtsolver cfg of
- Just smt -> do found <- findSmtSolver smt
- case found of
- Just _ -> return cfg
- Nothing -> panic Nothing (missingSmtError smt)
- Nothing -> do smts <- mapM findSmtSolver [FC.Z3, FC.Cvc4, FC.Mathsat]
- case catMaybes smts of
- (s:_) -> return (cfg {smtsolver = Just s})
- _ -> panic Nothing noSmtError
- where
- noSmtError = "LiquidHaskell requires an SMT Solver, i.e. z3, cvc4, or mathsat to be installed."
- missingSmtError smt = "Could not find SMT solver '" ++ show smt ++ "'. Is it on your PATH?"
-
-findSmtSolver :: FC.SMTSolver -> IO (Maybe FC.SMTSolver)
-findSmtSolver smt = maybe Nothing (const $ Just smt) <$> findExecutable (show smt)
-
-fixConfig :: Config -> IO Config
-fixConfig cfg = do
- pwd <- getCurrentDirectory
- cfg <- canonicalizePaths pwd cfg
- return $ canonConfig cfg
-
--- | Attempt to canonicalize all `FilePath's in the `Config' so we don't have
--- to worry about relative paths.
-canonicalizePaths :: FilePath -> Config -> IO Config
-canonicalizePaths pwd cfg = do
- tgt <- canonicalizePath pwd
- isdir <- doesDirectoryExist tgt
- is <- mapM (canonicalize tgt isdir) $ idirs cfg
- cs <- mapM (canonicalize tgt isdir) $ cFiles cfg
- return $ cfg { idirs = is, cFiles = cs }
-
-canonicalize :: FilePath -> Bool -> FilePath -> IO FilePath
-canonicalize tgt isdir f
- | isAbsolute f = return f
- | isdir = canonicalizePath (tgt f)
- | otherwise = canonicalizePath (takeDirectory tgt f)
-
-envCfg :: IO Config
-envCfg = do
- so <- lookupEnv "LIQUIDHASKELL_OPTS"
- case so of
- Nothing -> return defConfig
- Just s -> parsePragma $ envLoc s
- where
- envLoc = Loc l l
- l = newPos "ENVIRONMENT" 0 0
-
-copyright :: String
-copyright = concat $ concat
- [ ["LiquidHaskell "]
- , [$(simpleVersion Meta.version)]
- , [gitInfo]
- -- , [" (" ++ _commitCount ++ " commits)" | _commitCount /= ("1"::String) &&
- -- _commitCount /= ("UNKNOWN" :: String)]
- , ["\nCopyright 2013-19 Regents of the University of California. All Rights Reserved.\n"]
- ]
- where
- _commitCount = $gitCommitCount
-
-gitInfo :: String
-gitInfo = msg
- where
- giTry = $$tGitInfoCwdTry
- msg = case giTry of
- Left _ -> " no git information"
- Right gi -> gitMsg gi
-
-gitMsg :: GitInfo -> String
-gitMsg gi = concat
- [ " [", giBranch gi, "@", giHash gi
- , " (", giCommitDate gi, ")"
- -- , " (", show (giCommitCount gi), " commits in HEAD)"
- , "] "
- ]
-
-
--- [NOTE:searchpath]
--- 1. we used to add the directory containing the file to the searchpath,
--- but this is bad because GHC does NOT do this, and it causes spurious
--- "duplicate module" errors in the following scenario
--- > tree
--- .
--- ├── Bar.hs
--- └── Foo
--- ├── Bar.hs
--- └── Goo.hs
--- If we run `liquid Foo/Goo.hs` and that imports Bar, GHC will not know
--- whether we mean to import Bar.hs or Foo/Bar.hs
--- 2. tests fail if you flip order of idirs'
-
-mkOpts :: Config -> IO Config
-mkOpts cfg = do
- let files' = sortNub $ files cfg
- id0 <- getIncludeDir
- return $ cfg { files = files'
- -- See NOTE [searchpath]
- , idirs = [id0 gHC_VERSION, id0]
- ++ idirs cfg
- }
-
---------------------------------------------------------------------------------
--- | Updating options
---------------------------------------------------------------------------------
-canonConfig :: Config -> Config
-canonConfig cfg = cfg
- { diffcheck = diffcheck cfg && not (fullcheck cfg)
- -- , eliminate = if higherOrderFlag cfg then FC.All else eliminate cfg
- }
-
---------------------------------------------------------------------------------
-withPragmas :: Config -> FilePath -> [Located String] -> IO Config
---------------------------------------------------------------------------------
-withPragmas cfg fp ps
- = foldM withPragma cfg ps >>= canonicalizePaths fp >>= (return . canonConfig)
-
-withPragma :: Config -> Located String -> IO Config
-withPragma c s = withArgs [val s] $ cmdArgsRun
- config { modeValue = (modeValue config) { cmdArgsValue = c } }
-
-parsePragma :: Located String -> IO Config
-parsePragma = withPragma defConfig
-
-defConfig :: Config
-defConfig = Config
- { loggingVerbosity = Quiet
- , files = def
- , idirs = def
- , fullcheck = def
- , linear = def
- , stringTheory = def
- , higherorder = def
- , smtTimeout = def
- , higherorderqs = def
- , diffcheck = def
- , saveQuery = def
- , checks = def
- , nostructuralterm = def
- , noCheckUnknown = def
- , notermination = False
- , rankNTypes = False
- , noclasscheck = False
- , gradual = False
- , bscope = False
- , gdepth = 1
- , ginteractive = False
- , totalHaskell = def -- True
- , nowarnings = def
- , noannotations = def
- , checkDerived = False
- , caseExpandDepth = 2
- , notruetypes = def
- , nototality = False
- , pruneUnsorted = def
- , exactDC = def
- , noADT = def
- , cores = def
- , minPartSize = FC.defaultMinPartSize
- , maxPartSize = FC.defaultMaxPartSize
- , maxParams = defaultMaxParams
- , smtsolver = def
- , shortNames = def
- , shortErrors = def
- , cabalDir = def
- , ghcOptions = def
- , cFiles = def
- , port = defaultPort
- , scrapeInternals = False
- , scrapeImports = False
- , scrapeUsedImports = False
- , elimStats = False
- , elimBound = Nothing
- , json = False
- , counterExamples = False
- , timeBinds = False
- , untidyCore = False
- , eliminate = FC.Some
- , noPatternInline = False
- , noSimplifyCore = False
- -- PLE-OPT , autoInstantiate = def
- , noslice = False
- , noLiftedImport = False
- , proofLogicEval = False
- , oldPLE = False
- , proofLogicEvalLocal = False
- , reflection = False
- , extensionality = False
- , nopolyinfer = False
- , compileSpec = False
- , noCheckImports = False
- , typedHoles = False
- , maxMatchDepth = 4
- , maxAppDepth = 2
- , maxArgsDepth = 1
- , maxRWOrderingConstraints = Nothing
- , rwTerminationCheck = False
- }
-
-
--- | Writes the annotations (i.e. the files in the \".liquid\" hidden folder) and report the result
--- of the checking using a supplied function.
-reportResult :: MonadIO m
- => (OutputResult -> m ())
- -> Config
- -> [FilePath]
- -> Output Doc
- -> m ()
-reportResult logResultFull cfg targets out = do
- annm <- {-# SCC "annotate" #-} liftIO $ annotate cfg targets out
- liftIO $ whenNormal $ donePhase Loud "annotate"
- if | json cfg -> liftIO $ reportResultJson annm
- | otherwise -> do
- let r = o_result out
- liftIO $ writeCheckVars $ o_vars out
- cr <- liftIO $ resultWithContext r
- let outputResult = resDocs tidy cr
- -- For now, always print the \"header\" with colours, irrespective to the logger
- -- passed as input.
- liftIO $ printHeader (colorResult r) (orHeader outputResult)
- logResultFull outputResult
- pure ()
- where
- tidy :: F.Tidy
- tidy = if shortErrors cfg then F.Lossy else F.Full
-
- printHeader :: Moods -> Doc -> IO ()
- printHeader mood d = colorPhaseLn mood "" (render d)
-
-
-------------------------------------------------------------------------
-exitWithResult :: Config -> [FilePath] -> Output Doc -> IO ()
-------------------------------------------------------------------------
-exitWithResult cfg = reportResult writeResultStdout cfg
-
-reportResultJson :: ACSS.AnnMap -> IO ()
-reportResultJson annm = do
- putStrLn "LIQUID"
- B.putStrLn . encode . annErrors $ annm
-
-resultWithContext :: F.FixResult UserError -> IO (FixResult CError)
-resultWithContext (F.Unsafe s es) = F.Unsafe s <$> errorsWithContext es
-resultWithContext (F.Crash es s) = (`F.Crash` s) <$> errorsWithContext es
-resultWithContext (F.Safe stats) = return (F.Safe stats)
-
-instance Show (CtxError Doc) where
- show = showpp
-
-writeCheckVars :: Symbolic a => Maybe [a] -> IO ()
-writeCheckVars Nothing = return ()
-writeCheckVars (Just []) = colorPhaseLn Loud "Checked Binders: None" ""
-writeCheckVars (Just ns) = colorPhaseLn Loud "Checked Binders:" ""
- >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol)
-
-type CError = CtxError Doc
-
-data OutputResult = OutputResult {
- orHeader :: Doc
- -- ^ The \"header\" like \"LIQUID: SAFE\", or \"LIQUID: UNSAFE\".
- , orMessages :: [(GHC.SrcSpan, Doc)]
- -- ^ The list of pretty-printable messages (typically errors) together with their
- -- source locations.
- }
-
--- | Writes the result of this LiquidHaskell run to /stdout/.
-writeResultStdout :: OutputResult -> IO ()
-writeResultStdout (orMessages -> messages) = do
- forM_ messages $ \(sSpan, doc) -> putStrLn (render $ pprint sSpan <> (text ": error: " <+> doc))
-
--- | Given a 'FixResult' parameterised over a 'CError', this function returns the \"header\" to show to
--- the user (i.e. \"SAFE\" or \"UNSAFE\") plus a list of 'Doc's together with the 'SrcSpan' they refer to.
-resDocs :: F.Tidy -> F.FixResult CError -> OutputResult
-resDocs _ (F.Safe stats) =
- OutputResult {
- orHeader = text $ "LIQUID: SAFE (" <> show (Solver.numChck stats) <> " constraints checked)"
- , orMessages = mempty
- }
-resDocs k (F.Crash xs s) =
- OutputResult {
- orHeader = text "LIQUID: ERROR" <+> text s
- , orMessages = map (cErrToSpanned k . errToFCrash) xs
- }
-resDocs k (F.Unsafe _ xs) =
- OutputResult {
- orHeader = text "LIQUID: UNSAFE"
- , orMessages = map (cErrToSpanned k) (nub xs)
- }
-
--- | Renders a 'CError' into a 'Doc' and its associated 'SrcSpan'.
-cErrToSpanned :: F.Tidy -> CError -> (GHC.SrcSpan, Doc)
-cErrToSpanned k CtxError{ctErr} = (pos ctErr, pprintTidy k ctErr)
-
-errToFCrash :: CtxError a -> CtxError a
-errToFCrash ce = ce { ctErr = tx $ ctErr ce}
- where
- tx (ErrSubType l m g t t') = ErrFCrash l m g t t'
- tx e = e
-
-{-
- TODO: Never used, do I need to exist?
-reportUrl = text "Please submit a bug report at: https://github.com/ucsd-progsys/liquidhaskell" -}
-
-addErrors :: FixResult a -> [a] -> FixResult a
-addErrors r [] = r
-addErrors (Safe s) errs = Unsafe s errs
-addErrors (Unsafe s xs) errs = Unsafe s (xs ++ errs)
-addErrors r _ = r
-
-instance Fixpoint (F.FixResult CError) where
- toFix = vcat . map snd . orMessages . resDocs F.Full
diff --git a/src/Language/Haskell/Liquid/UX/Config.hs b/src/Language/Haskell/Liquid/UX/Config.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/UX/Config.hs
+++ /dev/null
@@ -1,155 +0,0 @@
--- | Command Line Configuration Options ----------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-
-module Language.Haskell.Liquid.UX.Config (
- Config (..)
- , HasConfig (..)
- , allowPLE, allowLocalPLE, allowGlobalPLE
- , patternFlag
- , higherOrderFlag
- , pruneFlag
- , maxCaseExpand
- , exactDCFlag
- , hasOpt
- , totalityCheck
- , terminationCheck
- , structuralTerm
- ) where
-
-import Prelude hiding (error)
-import Language.Fixpoint.Types.Config hiding (Config)
-import GHC.Generics
-import System.Console.CmdArgs
-
--- NOTE: adding strictness annotations breaks the help message
-data Config = Config
- { loggingVerbosity :: Verbosity -- ^ the logging verbosity to use (defaults to 'Quiet')
- , files :: [FilePath] -- ^ source files to check
- , idirs :: [FilePath] -- ^ path to directory for including specs
- , diffcheck :: Bool -- ^ check subset of binders modified (+ dependencies) since last check
- , linear :: Bool -- ^ uninterpreted integer multiplication and division
- , stringTheory :: Bool -- ^ interpretation of string theory in the logic
- , higherorder :: Bool -- ^ allow higher order binders into the logic
- , higherorderqs :: Bool -- ^ allow higher order qualifiers
- , smtTimeout :: Maybe Int -- ^ smt timeout
- , fullcheck :: Bool -- ^ check all binders (overrides diffcheck)
- , saveQuery :: Bool -- ^ save fixpoint query
- , checks :: [String] -- ^ set of binders to check
- , noCheckUnknown :: Bool -- ^ whether to complain about specifications for unexported and unused values
- , notermination :: Bool -- ^ disable termination check
- , rankNTypes :: Bool -- ^ Adds precise reasoning on presence of rankNTypes
- , noclasscheck :: Bool -- ^ disable checking class instances
- -- , structuralTerm :: Bool -- ^ use structural termination checker
- , nostructuralterm :: Bool -- ^ disable structural termination check
- , gradual :: Bool -- ^ enable gradual type checking
- , bscope :: Bool -- ^ scope of the outer binders on the inner refinements
- , gdepth :: Int -- ^ depth of gradual concretization
- , ginteractive :: Bool -- ^ interactive gradual solving
- , totalHaskell :: Bool -- ^ Check for termination and totality, Overrides no-termination flags
- , nowarnings :: Bool -- ^ disable warnings output (only show errors)
- , noannotations :: Bool -- ^ disable creation of intermediate annotation files
- , checkDerived :: Bool -- ^ check internal (GHC-derived) binders
- , caseExpandDepth :: Int -- ^ maximum case expand nesting depth.
- , notruetypes :: Bool -- ^ disable truing top level types
- , nototality :: Bool -- ^ disable totality check in definitions
- , pruneUnsorted :: Bool -- ^ enable prunning unsorted Refinements
- , cores :: Maybe Int -- ^ number of cores used to solve constraints
- , minPartSize :: Int -- ^ Minimum size of a partition
- , maxPartSize :: Int -- ^ Maximum size of a partition. Overrides minPartSize
- , maxParams :: Int -- ^ the maximum number of parameters to accept when mining qualifiers
- , smtsolver :: Maybe SMTSolver -- ^ name of smtsolver to use [default: try z3, cvc4, mathsat in order]
- , shortNames :: Bool -- ^ drop module qualifers from pretty-printed names.
- , shortErrors :: Bool -- ^ don't show subtyping errors and contexts.
- , cabalDir :: Bool -- ^ find and use .cabal file to include paths to sources for imported modules
- , ghcOptions :: [String] -- ^ command-line options to pass to GHC
- , cFiles :: [String] -- ^ .c files to compile and link against (for GHC)
- , eliminate :: Eliminate -- ^ eliminate (i.e. don't use qualifs for) for "none", "cuts" or "all" kvars
- , port :: Int -- ^ port at which lhi should listen
- , exactDC :: Bool -- ^ Automatically generate singleton types for data constructors
- , noADT :: Bool -- ^ Disable ADTs (only used with exactDC)
- , scrapeImports :: Bool -- ^ scrape qualifiers from imported specifications
- , scrapeInternals :: Bool -- ^ scrape qualifiers from auto specifications
- , scrapeUsedImports :: Bool -- ^ scrape qualifiers from used, imported specifications
- , elimStats :: Bool -- ^ print eliminate stats
- , elimBound :: Maybe Int -- ^ eliminate upto given depth of KVar chains
- , json :: Bool -- ^ print results (safe/errors) as JSON
- , counterExamples :: Bool -- ^ attempt to generate counter-examples to type errors
- , timeBinds :: Bool -- ^ check and time each (asserted) type-sig separately
- , noPatternInline :: Bool -- ^ treat code patterns (e.g. e1 >>= \x -> e2) specially for inference
- , untidyCore :: Bool -- ^ print full blown core (with untidy names) in verbose mode
- , noSimplifyCore :: Bool -- ^ simplify GHC core before constraint-generation
- -- PLE-OPT , autoInst ntiate :: Instantiate -- ^ How to instantiate axioms
- , noslice :: Bool -- ^ Disable non-concrete KVar slicing
- , noLiftedImport :: Bool -- ^ Disable loading lifted specifications (for "legacy" libs)
- , proofLogicEval :: Bool -- ^ Enable proof-by-logical-evaluation
- , oldPLE :: Bool -- ^ Enable proof-by-logical-evaluation
- , proofLogicEvalLocal :: Bool -- ^ Enable proof-by-logical-evaluation locally, per function
- , extensionality :: Bool -- ^ Enable extensional interpretation of function equality
- , nopolyinfer :: Bool -- ^ No inference of polymorphic type application.
- , reflection :: Bool -- ^ Allow "reflection"; switches on "--higherorder" and "--exactdc"
- , compileSpec :: Bool -- ^ Only "compile" the spec -- into .bspec file -- don't do any checking.
- , noCheckImports :: Bool -- ^ Do not check the transitive imports
- , typedHoles :: Bool -- ^ Warn about "typed-holes"
- , maxMatchDepth :: Int
- , maxAppDepth :: Int
- , maxArgsDepth :: Int
- , maxRWOrderingConstraints :: Maybe Int
- , rwTerminationCheck :: Bool
- } deriving (Generic, Data, Typeable, Show, Eq)
-
-allowPLE :: Config -> Bool
-allowPLE cfg
- = allowGlobalPLE cfg
- || allowLocalPLE cfg
-
-allowGlobalPLE :: Config -> Bool
-allowGlobalPLE cfg = proofLogicEval cfg
-
-allowLocalPLE :: Config -> Bool
-allowLocalPLE cfg = proofLogicEvalLocal cfg
-
-instance HasConfig Config where
- getConfig x = x
-
-class HasConfig t where
- getConfig :: t -> Config
-
-patternFlag :: (HasConfig t) => t -> Bool
-patternFlag = not . noPatternInline . getConfig
-
-higherOrderFlag :: (HasConfig t) => t -> Bool
-higherOrderFlag x = higherorder cfg || reflection cfg
- where
- cfg = getConfig x
-
-exactDCFlag :: (HasConfig t) => t -> Bool
-exactDCFlag x = exactDC cfg || reflection cfg
- where
- cfg = getConfig x
-
-pruneFlag :: (HasConfig t) => t -> Bool
-pruneFlag = pruneUnsorted . getConfig
-
-maxCaseExpand :: (HasConfig t) => t -> Int
-maxCaseExpand = caseExpandDepth . getConfig
-
-hasOpt :: (HasConfig t) => t -> (Config -> Bool) -> Bool
-hasOpt t f = f (getConfig t)
-
-totalityCheck :: (HasConfig t) => t -> Bool
-totalityCheck = totalityCheck' . getConfig
-
-terminationCheck :: (HasConfig t) => t -> Bool
-terminationCheck = terminationCheck' . getConfig
-
-totalityCheck' :: Config -> Bool
-totalityCheck' cfg = (not (nototality cfg)) || totalHaskell cfg
-
-terminationCheck' :: Config -> Bool
-terminationCheck' cfg = (totalHaskell cfg || not (notermination cfg))
-
-structuralTerm :: (HasConfig a) => a -> Bool
-structuralTerm = not . nostructuralterm . getConfig
-
diff --git a/src/Language/Haskell/Liquid/UX/DiffCheck.hs b/src/Language/Haskell/Liquid/UX/DiffCheck.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/UX/DiffCheck.hs
+++ /dev/null
@@ -1,546 +0,0 @@
--- | This module contains the code for Incremental checking, which finds the
--- part of a target file (the subset of the @[CoreBind]@ that have been
--- modified since it was last checked, as determined by a diff against
--- a saved version of the file.
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-module Language.Haskell.Liquid.UX.DiffCheck (
-
- -- * Changed binders + Unchanged Errors
- DiffCheck (..)
-
- -- * Use previously saved info to generate DiffCheck target
- , slice
-
- -- * Use target binders to generate DiffCheck target
- , thin -- , ThinDeps (..)
-
- -- * Save current information for next time
- , saveResult
-
- -- * Names of top-level binders that are rechecked
- , checkedVars
-
- -- * CoreBinds defining given set of Var
- , filterBinds
- , coreDeps
- , dependsOn
- )
- where
-
-
-import FastString (FastString)
-import Prelude hiding (error)
-import Data.Aeson
-import qualified Data.Text as T
-import Data.Algorithm.Diff
-import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)
-import qualified Data.IntervalMap.FingerTree as IM
-import CoreSyn hiding (sourceName)
-import Name (getSrcSpan, NamedThing)
-import Outputable (Outputable, OutputableBndr)
-import SrcLoc hiding (Located)
-import Var
-import qualified Data.HashSet as S
-import qualified Data.HashMap.Strict as M
-import qualified Data.List as L
-import System.Directory (copyFile, doesFileExist)
-import Language.Fixpoint.Types (atLoc, FixResult (..))
-import Language.Fixpoint.Utils.Files
-import Language.Fixpoint.Solver.Stats as Solver
-import Language.Haskell.Liquid.Misc (ifM, mkGraph)
-import Language.Haskell.Liquid.GHC.Misc
--- import Language.Haskell.Liquid.Types.Visitors
-import Text.Parsec.Pos (sourceName, sourceLine, sourceColumn, SourcePos, newPos)
-import Text.PrettyPrint.HughesPJ (text, render, Doc)
--- import Language.Haskell.Liquid.Types.Errors
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LB
-
-import Language.Haskell.Liquid.Types hiding (Def, LMap)
-
---------------------------------------------------------------------------------
--- | Data Types ----------------------------------------------------------------
---------------------------------------------------------------------------------
-
--- | Main type of value returned for diff-check.
-data DiffCheck = DC { newBinds :: [CoreBind]
- , oldOutput :: !(Output Doc)
- , newSpec :: !TargetSpec
- }
-
-instance PPrint DiffCheck where
- pprintTidy k = pprintTidy k . checkedVars
-
--- | Variable definitions
-data Def = D { start :: Int -- ^ line at which binder definition starts
- , end :: Int -- ^ line at which binder definition ends
- , binder :: Var -- ^ name of binder
- }
- deriving (Eq, Ord)
-
--- | Variable dependencies "call-graph"
-type Deps = M.HashMap Var (S.HashSet Var)
-
--- | Map from saved-line-num ---> current-line-num
-type LMap = IM.IntervalMap Int Int
-
--- | Intervals of line numbers that have been re-checked
-type ChkItv = IM.IntervalMap Int ()
-
-instance Show Def where
- show (D i j x) = showPpr x ++ " start: " ++ show i ++ " end: " ++ show j
-
---------------------------------------------------------------------------------
--- | `checkedNames` returns the names of the top-level binders that will be checked
---------------------------------------------------------------------------------
-checkedVars :: DiffCheck -> [Var]
-checkedVars = concatMap names . newBinds
- where
- names (NonRec v _ ) = [v]
- names (Rec xs) = fst <$> xs
-
---------------------------------------------------------------------------------
--- | `slice` returns a subset of the @[CoreBind]@ of the input `target`
--- file which correspond to top-level binders whose code has changed
--- and their transitive dependencies.
---------------------------------------------------------------------------------
-slice :: FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
---------------------------------------------------------------------------------
-slice target cbs sp = ifM (doesFileExist savedFile)
- doDiffCheck
- (return Nothing)
- where
- savedFile = extFileName Saved target
- doDiffCheck = sliceSaved target savedFile cbs sp
-
-sliceSaved :: FilePath -> FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
-sliceSaved target savedFile coreBinds spec = do
- (is, lm) <- lineDiff target savedFile
- result <- loadResult target
- return $ sliceSaved' target is lm (DC coreBinds result spec)
-
-sliceSaved' :: FilePath -> [Int] -> LMap -> DiffCheck -> Maybe DiffCheck
-sliceSaved' srcF is lm (DC coreBinds result spec)
- | gDiff = Nothing
- | otherwise = Just $ DC cbs' res' sp'
- where
- gDiff = globalDiff srcF is spec
- sp' = assumeSpec sigm spec
- res' = adjustOutput lm cm result
- cm = checkedItv (coreDefs cbs')
- cbs' = thinWith sigs coreBinds (diffVars is defs)
- defs = coreDefs coreBinds ++ specDefs srcF spec
- sigs = S.fromList $ M.keys sigm
- sigm = sigVars srcF is spec
-
--- | Add the specified signatures for vars-with-preserved-sigs,
--- whose bodies have been pruned from [CoreBind] into the "assumes"
-
-assumeSpec :: M.HashMap Var LocSpecType -> TargetSpec -> TargetSpec
-assumeSpec sigm sp = sp { gsSig = gsig { gsAsmSigs = M.toList $ M.union sigm assm } }
- where
- assm = M.fromList (gsAsmSigs gsig)
- gsig = gsSig sp
-
-diffVars :: [Int] -> [Def] -> [Var]
-diffVars ls defs' = -- tracePpr ("INCCHECK: diffVars lines = " ++ show ls ++ " defs= " ++ show defs) $
- go (L.sort ls) defs
- where
- defs = L.sort defs'
- go _ [] = []
- go [] _ = []
- go (i:is) (d:ds)
- | i < start d = go is (d:ds)
- | i > end d = go (i:is) ds
- | otherwise = binder d : go (i:is) ds
-
-sigVars :: FilePath -> [Int] -> TargetSpec -> M.HashMap Var LocSpecType
-sigVars srcF ls sp = M.fromList $ filter (ok . snd) $ specSigs sp
- where
- ok = not . isDiff srcF ls
-
-globalDiff :: FilePath -> [Int] -> TargetSpec -> Bool
-globalDiff srcF ls gspec = measDiff || invsDiff || dconsDiff
- where
- measDiff = any (isDiff srcF ls) (snd <$> gsMeas spec)
- invsDiff = any (isDiff srcF ls) (snd <$> gsInvariants spec)
- dconsDiff = any (isDiff srcF ls) [ atLoc ldc () | ldc <- gsDconsP (gsName gspec) ]
- spec = gsData gspec
- -- (dloc . snd <$> gsDconsP spec)
- -- dloc dc = Loc (dc_loc dc) (dc_locE dc) ()
-
-
-isDiff :: FilePath -> [Int] -> Located a -> Bool
-isDiff srcF ls x = file x == srcF && any hits ls
- where
- hits i = line x <= i && i <= lineE x
-
---------------------------------------------------------------------------------
--- | @thin cbs sp vs@ returns a subset of the @cbs :: [CoreBind]@ which
--- correspond to the definitions of @vs@ and the functions transitively
--- called therein for which there are *no* type signatures. Callees with
--- type signatures are assumed to satisfy those signatures.
---------------------------------------------------------------------------------
-
-{- data ThinDeps = Trans [Var] -- ^ Check all transitive dependencies
- | None Var -- ^ Check only the given binders
- -}
-
---------------------------------------------------------------------------------
-thin :: [CoreBind] -> TargetSpec -> [Var] -> DiffCheck
---------------------------------------------------------------------------------
--- thin cbs sp (Trans vs) = DC (thinWith S.empty cbs vs ) mempty sp
-thin cbs sp vs = DC (filterBinds cbs vs') mempty sp'
- where
- vs' = txClosure (coreDeps cbs) xs (S.fromList vs)
- sp' = assumeSpec sigs' sp
- sigs' = foldr M.delete (M.fromList xts) vs
- xts = specSigs sp
- xs = S.fromList $ fst <$> xts
-
-thinWith :: S.HashSet Var -> [CoreBind] -> [Var] -> [CoreBind]
-thinWith sigs cbs xs = filterBinds cbs ys
- where
- ys = calls `S.union` calledBy
- calls = txClosure (coreDeps cbs) sigs (S.fromList xs)
- calledBy = dependsOn (coreDeps cbs) xs
-
-coreDeps :: [CoreBind] -> Deps
-coreDeps bs = mkGraph $ calls ++ calls'
- where
- calls = concatMap deps bs
- calls' = [(y, x) | (x, y) <- calls]
- deps b = [(x, y) | x <- bindersOf b
- , y <- freeVars S.empty b]
-
--- | Given a call graph, and a list of vars, `dependsOn`
--- checks all functions to see if they call any of the
--- functions in the vars list.
--- If any do, then they must also be rechecked.
-
-dependsOn :: Deps -> [Var] -> S.HashSet Var
-dependsOn cg vars = S.fromList results
- where
- preds = map S.member vars
- filteredMaps = M.filter <$> preds <*> pure cg
- results = map fst $ M.toList $ M.unions filteredMaps
-
-txClosure :: Deps -> S.HashSet Var -> S.HashSet Var -> S.HashSet Var
-txClosure d sigs = go S.empty
- where
- next = S.unions . fmap deps . S.toList
- deps x = M.lookupDefault S.empty x d
- go seen new
- | S.null new = seen
- | otherwise = let seen' = S.union seen new
- new' = next new `S.difference` seen'
- new'' = new' `S.difference` sigs
- in go seen' new''
-
-
-
---------------------------------------------------------------------------------
-filterBinds :: [CoreBind] -> S.HashSet Var -> [CoreBind]
---------------------------------------------------------------------------------
-filterBinds cbs ys = filter f cbs
- where
- f (NonRec x _) = x `S.member` ys
- f (Rec xes) = any (`S.member` ys) $ fst <$> xes
-
-
---------------------------------------------------------------------------------
-specDefs :: FilePath -> TargetSpec -> [Def]
---------------------------------------------------------------------------------
-specDefs srcF = map def . filter sameFile . specSigs
- where
- def (x, t) = D (line t) (lineE t) x
- sameFile = (srcF ==) . file . snd
-
-specSigs :: TargetSpec -> [(Var, LocSpecType)]
-specSigs sp = gsTySigs (gsSig sp)
- ++ gsAsmSigs (gsSig sp)
- ++ gsCtors (gsData sp)
-
---------------------------------------------------------------------------------
-coreDefs :: [CoreBind] -> [Def]
---------------------------------------------------------------------------------
-coreDefs cbs = L.sort [D l l' x | b <- cbs
- , x <- bindersOf b
- , isGoodSrcSpan (getSrcSpan x)
- , (l, l') <- coreDef b]
-
-coreDef :: (NamedThing a, OutputableBndr a)
- => Bind a -> [(Int, Int)]
-coreDef b = meetSpans b eSp vSp
- where
- eSp = lineSpan b $ catSpans b $ bindSpans b
- vSp = lineSpan b $ catSpans b $ getSrcSpan <$> bindersOf b
-
-
---------------------------------------------------------------------------------
--- | `meetSpans` cuts off the start-line to be no less than the line at which
--- the binder is defined. Without this, i.e. if we ONLY use the ticks and
--- spans appearing inside the definition of the binder (i.e. just `eSp`)
--- then the generated span can be WAY before the actual definition binder,
--- possibly due to GHC INLINE pragmas or dictionaries OR ...
--- for an example: see the "INCCHECK: Def" generated by
--- liquid -d benchmarks/bytestring-0.9.2.1/Data/ByteString.hs
--- where `spanEnd` is a single line function around 1092 but where
--- the generated span starts mysteriously at 222 where Data.List is imported.
-
-meetSpans :: Ord t1 => t -> Maybe (t1, t2) -> Maybe (t1, t3) -> [(t1, t2)]
-meetSpans _ Nothing _
- = []
-meetSpans _ (Just (l,l')) Nothing
- = [(l, l')]
-meetSpans _ (Just (l,l')) (Just (m,_))
- = [(max l m, l')]
-
-lineSpan :: t -> SrcSpan -> Maybe (Int, Int)
-lineSpan _ (RealSrcSpan sp) = Just (srcSpanStartLine sp, srcSpanEndLine sp)
-lineSpan _ _ = Nothing
-
-catSpans :: (NamedThing r, OutputableBndr r)
- => Bind r -> [SrcSpan] -> SrcSpan
-catSpans b [] = panic Nothing $ "DIFFCHECK: catSpans: no spans found for " ++ showPpr b
-catSpans b xs = foldr combineSrcSpans noSrcSpan [x | x@(RealSrcSpan z) <- xs, bindFile b == srcSpanFile z]
-
-bindFile
- :: (Outputable r, NamedThing r) =>
- Bind r -> FastString
-bindFile (NonRec x _) = varFile x
-bindFile (Rec xes) = varFile $ fst $ head xes
-
-varFile :: (Outputable a, NamedThing a) => a -> FastString
-varFile b = case getSrcSpan b of
- RealSrcSpan z -> srcSpanFile z
- _ -> panic Nothing $ "DIFFCHECK: getFile: no file found for: " ++ showPpr b
-
-
-bindSpans :: NamedThing a => Bind a -> [SrcSpan]
-bindSpans (NonRec x e) = getSrcSpan x : exprSpans e
-bindSpans (Rec xes) = map getSrcSpan xs ++ concatMap exprSpans es
- where
- (xs, es) = unzip xes
-
-exprSpans :: NamedThing a => Expr a -> [SrcSpan]
-exprSpans (Tick t e)
- | isJunkSpan sp = exprSpans e
- | otherwise = [sp]
- where
- sp = tickSrcSpan t
-
-exprSpans (Var x) = [getSrcSpan x]
-exprSpans (Lam x e) = getSrcSpan x : exprSpans e
-exprSpans (App e a) = exprSpans e ++ exprSpans a
-exprSpans (Let b e) = bindSpans b ++ exprSpans e
-exprSpans (Cast e _) = exprSpans e
-exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs
-exprSpans _ = []
-
-altSpans :: (NamedThing a, NamedThing a1) => (t, [a], Expr a1) -> [SrcSpan]
-altSpans (_, xs, e) = map getSrcSpan xs ++ exprSpans e
-
-isJunkSpan :: SrcSpan -> Bool
-isJunkSpan (RealSrcSpan _) = False
-isJunkSpan _ = True
-
---------------------------------------------------------------------------------
--- | Diff Interface ------------------------------------------------------------
---------------------------------------------------------------------------------
--- | `lineDiff new old` compares the contents of `src` with `dst`
--- and returns the lines of `src` that are different.
---------------------------------------------------------------------------------
-lineDiff :: FilePath -> FilePath -> IO ([Int], LMap)
---------------------------------------------------------------------------------
-lineDiff new old = lineDiff' <$> getLines new <*> getLines old
- where
- getLines = fmap lines . readFile
-
-lineDiff' :: [String] -> [String] -> ([Int], LMap)
-lineDiff' new old = (changedLines, lm)
- where
- changedLines = diffLines 1 diffLineCount
- lm = foldr setShift IM.empty $ diffShifts diffLineCount
- diffLineCount = fmap length <$> getGroupedDiff new old
-
--- | Identifies lines that have changed
-diffLines :: Int -- ^ Starting line
- -> [Diff Int] -- ^ List of lengths of diffs
- -> [Int] -- ^ List of changed line numbers
-diffLines _ [] = []
-diffLines curr (Both lnsUnchgd _ : d) = diffLines toSkip d
- where toSkip = curr + lnsUnchgd
-diffLines curr (First lnsChgd : d) = [curr..(toTake-1)] ++ diffLines toTake d
- where toTake = curr + lnsChgd
-diffLines curr (_ : d) = diffLines curr d
-
-diffShifts :: [Diff Int] -> [(Int, Int, Int)]
-diffShifts = go 1 1
- where
- go old new (Both n _ : d) = (old, old + n - 1, new - old) : go (old + n)
- (new + n)
- d
- go old new (Second n : d) = go (old + n) new d
- go old new (First n : d) = go old (new + n) d
- go _ _ [] = []
-
-instance Functor Diff where
- fmap f (First x) = First (f x)
- fmap f (Second x) = Second (f x)
- fmap f (Both x y) = Both (f x) (f y)
-
--- | @save@ creates an .saved version of the @target@ file, which will be
--- used to find what has changed the /next time/ @target@ is checked.
---------------------------------------------------------------------------------
-saveResult :: FilePath -> Output Doc -> IO ()
---------------------------------------------------------------------------------
-saveResult target res
- = do copyFile target saveF
- B.writeFile errF $ LB.toStrict $ encode res
- where
- saveF = extFileName Saved target
- errF = extFileName Cache target
-
---------------------------------------------------------------------------------
-loadResult :: FilePath -> IO (Output Doc)
---------------------------------------------------------------------------------
-loadResult f = ifM (doesFileExist jsonF) out (return mempty)
- where
- jsonF = extFileName Cache f
- out = (fromMaybe mempty . decode . LB.fromStrict) <$> B.readFile jsonF
-
---------------------------------------------------------------------------------
-adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc
---------------------------------------------------------------------------------
-adjustOutput lm cm o = mempty { o_types = adjustTypes lm cm (o_types o) }
- { o_result = adjustResult lm cm (o_result o) }
-
-adjustTypes :: LMap -> ChkItv -> AnnInfo a -> AnnInfo a
-adjustTypes lm cm (AI m) = AI $ M.fromList
- [(sp', v) | (sp, v) <- M.toList m
- , Just sp' <- [adjustSrcSpan lm cm sp]]
-
-adjustResult :: LMap -> ChkItv -> ErrorResult -> ErrorResult
-adjustResult lm cm (Unsafe s es) = errorsResult (Unsafe s) $ adjustErrors lm cm es
-adjustResult lm cm (Crash es z) = errorsResult (`Crash` z) $ adjustErrors lm cm es
-adjustResult _ _ r = r
-
-errorsResult :: ([a] -> FixResult b) -> [a] -> FixResult b
-errorsResult _ [] = Safe mempty
-errorsResult f es = f es
-
-adjustErrors :: LMap -> ChkItv -> [TError a] -> [TError a]
-adjustErrors lm cm = mapMaybe adjustError
- where
- adjustError e = case adjustSrcSpan lm cm (pos e) of
- Just sp' -> Just (e {pos = sp'})
- Nothing -> Nothing
-
- -- adjustError (ErrSaved sp m) = (`ErrSaved` m) <$>
- -- adjustError e = Just e
-
---------------------------------------------------------------------------------
-adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan
---------------------------------------------------------------------------------
-adjustSrcSpan lm cm sp
- = do sp' <- adjustSpan lm sp
- if isCheckedSpan cm sp'
- then Nothing
- else Just sp'
-
-isCheckedSpan :: IM.IntervalMap Int a -> SrcSpan -> Bool
-isCheckedSpan cm (RealSrcSpan sp) = isCheckedRealSpan cm sp
-isCheckedSpan _ _ = False
-
-isCheckedRealSpan :: IM.IntervalMap Int a -> RealSrcSpan -> Bool
-isCheckedRealSpan cm = not . null . (`IM.search` cm) . srcSpanStartLine
-
-adjustSpan :: LMap -> SrcSpan -> Maybe SrcSpan
-adjustSpan lm (RealSrcSpan rsp) = RealSrcSpan <$> adjustReal lm rsp
-adjustSpan _ sp = Just sp
-
-adjustReal :: LMap -> RealSrcSpan -> Maybe RealSrcSpan
-adjustReal lm rsp
- | Just δ <- getShift l1 lm = Just $ realSrcSpan f (l1 + δ) c1 (l2 + δ) c2
- | otherwise = Nothing
- where
- (f, l1, c1, l2, c2) = unpackRealSrcSpan rsp
-
-
--- | @getShift lm old@ returns @Just δ@ if the line number @old@ shifts by @δ@
--- in the diff and returns @Nothing@ otherwise.
-getShift :: Int -> LMap -> Maybe Int
-getShift old = fmap snd . listToMaybe . IM.search old
-
--- | @setShift (lo, hi, δ) lm@ updates the interval map @lm@ appropriately
-setShift :: (Int, Int, Int) -> LMap -> LMap
-setShift (l1, l2, δ) = IM.insert (IM.Interval l1 l2) δ
-
-
-checkedItv :: [Def] -> ChkItv
-checkedItv chDefs = foldr (`IM.insert` ()) IM.empty is
- where
- is = [IM.Interval l1 l2 | D l1 l2 _ <- chDefs]
-
-
---------------------------------------------------------------------------------
--- | Aeson instances -----------------------------------------------------------
---------------------------------------------------------------------------------
-
-instance ToJSON SourcePos where
- toJSON p = object [ "sourceName" .= f
- , "sourceLine" .= l
- , "sourceColumn" .= c
- ]
- where
- f = sourceName p
- l = sourceLine p
- c = sourceColumn p
-
-instance FromJSON SourcePos where
- parseJSON (Object v) = newPos <$> v .: "sourceName"
- <*> v .: "sourceLine"
- <*> v .: "sourceColumn"
- parseJSON _ = mempty
-
-instance ToJSON Solver.Stats where
- toJSON = genericToJSON defaultOptions
- toEncoding = genericToEncoding defaultOptions
-instance FromJSON Solver.Stats
-
-instance ToJSON ErrorResult where
- toJSON = genericToJSON defaultOptions
- toEncoding = genericToEncoding defaultOptions
-instance FromJSON ErrorResult
-
-instance ToJSON Doc where
- toJSON = String . T.pack . render
-
-instance FromJSON Doc where
- parseJSON (String s) = return $ text $ T.unpack s
- parseJSON _ = mempty
-
-instance ToJSON a => ToJSON (AnnInfo a) where
- toJSON = genericToJSON defaultOptions
- toEncoding = genericToEncoding defaultOptions
-instance FromJSON a => FromJSON (AnnInfo a)
-
-instance ToJSON (Output Doc) where
- toJSON = genericToJSON defaultOptions
- toEncoding = genericToEncoding defaultOptions
-instance FromJSON (Output Doc)
-
-
-file :: Located a -> FilePath
-file = sourceName . loc
-
-line :: Located a -> Int
-line = sourceLine . loc
-
-lineE :: Located a -> Int
-lineE = sourceLine . locE
diff --git a/src/Language/Haskell/Liquid/UX/Errors.hs b/src/Language/Haskell/Liquid/UX/Errors.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/UX/Errors.hs
+++ /dev/null
@@ -1,177 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE BangPatterns #-}
-
--- | This module contains the functions related to @Error@ type,
--- in particular, to @tidyError@ using a solution, and @pprint@ errors.
-
-module Language.Haskell.Liquid.UX.Errors ( tidyError ) where
-
-import Control.Arrow (second)
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-import qualified Data.List as L
-import Data.Hashable
-import Data.Maybe (maybeToList)
-import qualified Language.Fixpoint.Types as F
-import Language.Haskell.Liquid.Types.RefType
-import Language.Haskell.Liquid.Transforms.Simplify
-import Language.Haskell.Liquid.UX.Tidy
-import Language.Haskell.Liquid.Types
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
-import qualified Language.Haskell.Liquid.Misc as Misc
-import qualified Language.Fixpoint.Misc as Misc
-
--- import Debug.Trace
-
-type Ctx = M.HashMap F.Symbol SpecType
-type CtxM = M.HashMap F.Symbol (WithModel SpecType)
-
-------------------------------------------------------------------------
-tidyError :: Config -> F.FixSolution -> Error -> Error
-------------------------------------------------------------------------
-tidyError cfg sol
- = fmap (tidySpecType tidy)
- . tidyErrContext tidy sol
- where
- tidy = configTidy cfg
-
-configTidy :: Config -> F.Tidy
-configTidy cfg
- | shortNames cfg = F.Lossy
- | otherwise = F.Full
-
-tidyErrContext :: F.Tidy -> F.FixSolution -> Error -> Error
-tidyErrContext k _ e@(ErrSubType {})
- = e { ctx = c', tact = F.subst θ tA, texp = F.subst θ tE }
- where
- (θ, c') = tidyCtx k xs (ctx e)
- xs = F.syms tA ++ F.syms tE
- tA = tact e
- tE = texp e
-
-tidyErrContext _ _ e@(ErrSubTypeModel {})
- = e { ctxM = c', tactM = fmap (F.subst θ) tA, texp = fmap (F.subst θ) tE }
- where
- (θ, c') = tidyCtxM xs $ ctxM e
- xs = F.syms tA ++ F.syms tE
- tA = tactM e
- tE = texp e
-
-tidyErrContext k _ e@(ErrAssType {})
- = e { ctx = c', cond = F.subst θ p }
- where
- m = ctx e
- (θ, c') = tidyCtx k xs m
- xs = F.syms p
- p = cond e
-
-tidyErrContext _ _ e
- = e
-
---------------------------------------------------------------------------------
-tidyCtx :: F.Tidy -> [F.Symbol] -> Ctx -> (F.Subst, Ctx)
---------------------------------------------------------------------------------
-tidyCtx k xs m = (θ1 `mappend` θ2, M.fromList yts)
- where
- yts = [tBind x (tidySpecType k t) | (x, t) <- xt2s]
- (θ2, xt2s) = tidyREnv xt1s
- (θ1, xt1s) = tidyTemps xts
- xts = sliceREnv xs m
- tBind x t = (x', shiftVV t x') where x' = F.tidySymbol x
-
-tidyCtxM :: [F.Symbol] -> CtxM -> (F.Subst, CtxM)
-tidyCtxM xs m = (θ, M.fromList yts)
- where
- yts = [tBind x t | (x, t) <- xts]
- (θ, xts) = tidyTemps $ second (fmap stripReft) <$> tidyREnvM xs m
- tBind x t = (x', fmap (\t -> shiftVV t x') t) where x' = F.tidySymbol x
-
-tidyREnv :: [(F.Symbol, SpecType)] -> (F.Subst, [(F.Symbol, SpecType)])
-tidyREnv xts = (θ, second (F.subst θ) <$> zts)
- where
- θ = expandVarDefs yes
- (yes, zts) = Misc.mapEither isInline xts
-
--- | 'expandVarDefs [(x1, e1), ... ,(xn, en)] returns a `Subst` that
--- contains the fully substituted definitions for each `xi`. For example,
--- expandVarDefs [(x1, 'x2 + x3'), (x5, 'x1 + 1')]
--- should return
--- [x1 := 'x2 + x3, x5 := (x2 + x3) + 1]
-
-expandVarDefs :: [(F.Symbol, F.Expr)] -> F.Subst
-expandVarDefs = go mempty
- where
- go !su xes
- | null yes = su `mappend` (F.mkSubst xes)
- | otherwise = go (su `mappend` su') xes''
- where
- xes'' = [(z, F.subst su' e) | (z, e) <- zes]
- xs = S.fromList [x | (x, _) <- xes]
- su' = F.mkSubst yes
- (yes, zes) = L.partition (isDef xs . snd) xes
- isDef xs e = all (not . (`S.member` xs)) (F.syms e)
-
-isInline :: (a, SpecType) -> Either (a, F.Expr) (a, SpecType)
-isInline (x, t) = either (Left . (x,)) (Right . (x,)) (isInline' t)
-
-isInline' :: SpecType -> Either F.Expr SpecType
-isInline' t = case ro of
- Nothing -> Right t'
- Just rr -> case F.isSingletonReft (ur_reft rr) of
- Just e -> Left e
- Nothing -> Right (strengthen t' rr)
- where
- (t', ro) = stripRType t
-
-stripReft :: SpecType -> SpecType
-stripReft t = maybe t' (strengthen t') ro
- where
- (t', ro) = stripRType t
-
-stripRType :: SpecType -> (SpecType, Maybe RReft)
-stripRType st = (t', ro)
- where
- t' = fmap (const (uTop mempty)) t
- ro = stripRTypeBase t
- t = simplifyBounds st
-
-sliceREnv :: [F.Symbol] -> Ctx -> [(F.Symbol, SpecType)]
-sliceREnv xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]
- where
- xs' = expandFix deps xs
- deps y = maybe [] (F.syms . rTypeReft) (M.lookup y m)
- ok = not . isFunTy
-
-tidyREnvM :: [F.Symbol] -> CtxM -> [(F.Symbol, WithModel SpecType)]
-tidyREnvM xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t]
- where
- xs' = expandFix deps xs
- deps y = maybe [] (F.syms . rTypeReft . dropModel) (M.lookup y m)
- ok = not . isFunTy . dropModel
-
-expandFix :: (Eq a, Hashable a) => (a -> [a]) -> [a] -> [a]
-expandFix f = S.toList . go S.empty
- where
- go seen [] = seen
- go seen (x:xs)
- | x `S.member` seen = go seen xs
- | otherwise = go (S.insert x seen) (f x ++ xs)
-
-tidyTemps :: (F.Subable t) => [(F.Symbol, t)] -> (F.Subst, [(F.Symbol, t)])
-tidyTemps xts = (θ, [(txB x, txTy t) | (x, t) <- xts])
- where
- txB x = M.lookupDefault x x m
- txTy = F.subst θ
- m = M.fromList yzs
- θ = F.mkSubst [(y, F.EVar z) | (y, z) <- yzs]
- yzs = zip ys niceTemps
- ys = [ x | (x,_) <- xts, GM.isTmpSymbol x]
-
-niceTemps :: [F.Symbol]
-niceTemps = mkSymbol <$> xs ++ ys
- where
- mkSymbol = F.symbol . ('?' :)
- xs = Misc.single <$> ['a' .. 'z']
- ys = ("a" ++) <$> [show n | n <- [0 ..]]
diff --git a/src/Language/Haskell/Liquid/UX/QuasiQuoter.hs b/src/Language/Haskell/Liquid/UX/QuasiQuoter.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/UX/QuasiQuoter.hs
+++ /dev/null
@@ -1,210 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Language.Haskell.Liquid.UX.QuasiQuoter
--- (
--- -- * LiquidHaskell Specification QuasiQuoter
--- lq
-
--- -- * QuasiQuoter Annotations
--- , LiquidQuote(..)
--- )
- where
-
-import SrcLoc (SrcSpan)
-
-import Data.Data
-import Data.List
-
-import qualified Data.Text as T
-
-import Language.Haskell.TH.Lib
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.Quote
-
-import Text.Parsec.Pos
-
-import Language.Fixpoint.Types hiding (Error, Loc, SrcSpan)
-import qualified Language.Fixpoint.Types as F
-
-import Language.Haskell.Liquid.GHC.Misc (fSrcSpan)
-import Language.Haskell.Liquid.Parse
-import Language.Haskell.Liquid.Types
-import Language.Haskell.Liquid.UX.Tidy
-
---------------------------------------------------------------------------------
--- LiquidHaskell Specification QuasiQuoter -------------------------------------
---------------------------------------------------------------------------------
-
-lq :: QuasiQuoter
-lq = QuasiQuoter
- { quoteExp = bad
- , quotePat = bad
- , quoteType = bad
- , quoteDec = lqDec
- }
- where
- -- FIME(adinapoli) Should we preserve 'fail' here?
- bad = error "`lq` quasiquoter can only be used as a top-level declaration"
-
-lqDec :: String -> Q [Dec]
-lqDec src = do
- pos <- locSourcePos <$> location
- case singleSpecP pos src of
- Left err -> throwErrorInQ $ errorToUserError err
- Right spec -> do
- prg <- pragAnnD ModuleAnnotation $
- conE 'LiquidQuote `appE` dataToExpQ' spec
- case mkSpecDecs spec of
- Left err ->
- throwErrorInQ err
- Right decs ->
- return $ prg : decs
-
-throwErrorInQ :: UserError -> Q a
-throwErrorInQ err =
- fail . showpp =<< runIO (errorsWithContext [err])
-
---------------------------------------------------------------------------------
--- Liquid Haskell to Template Haskell ------------------------------------------
---------------------------------------------------------------------------------
-
--- Spec to Dec -----------------------------------------------------------------
-
-mkSpecDecs :: BPspec -> Either UserError [Dec]
-mkSpecDecs (Asrt (name, ty)) =
- return . SigD (symbolName name)
- <$> simplifyBareType name (quantifyFreeRTy $ val ty)
-mkSpecDecs (LAsrt (name, ty)) =
- return . SigD (symbolName name)
- <$> simplifyBareType name (quantifyFreeRTy $ val ty)
-mkSpecDecs (Asrts (names, (ty, _))) =
- (\t -> (`SigD` t) . symbolName <$> names)
- <$> simplifyBareType (head names) (quantifyFreeRTy $ val ty)
-mkSpecDecs (Alias rta) =
- return . (TySynD name tvs) <$> simplifyBareType lsym (rtBody (val rta))
- where
- lsym = F.atLoc rta n
- name = symbolName n
- n = rtName (val rta)
- tvs = PlainTV . symbolName <$> rtTArgs (val rta)
-mkSpecDecs _ =
- Right []
-
--- Symbol to TH Name -----------------------------------------------------------
-
-symbolName :: Symbolic s => s -> Name
-symbolName = mkName . symbolString . symbol
-
--- BareType to TH Type ---------------------------------------------------------
-
-simplifyBareType :: LocSymbol -> BareType -> Either UserError Type
-simplifyBareType s t = case simplifyBareType' t of
- Simplified t' ->
- Right t'
- FoundExprArg l ->
- Left $ ErrTySpec l Nothing (pprint $ val s) (pprint t) $
- "Found expression argument in bad location in type"
- FoundHole ->
- Left $ ErrTySpec (fSrcSpan s) Nothing (pprint $ val s) (pprint t) $
- "Can't write LiquidHaskell type with hole in a quasiquoter"
-
-simplifyBareType' :: BareType -> Simpl Type
-simplifyBareType' = simplifyBareType'' ([], [])
-
-simplifyBareType'' :: ([BTyVar], [BareType]) -> BareType -> Simpl Type
-
-simplifyBareType'' ([], []) (RVar v _) =
- return $ VarT $ symbolName v
-simplifyBareType'' ([], []) (RAppTy t1 t2 _) =
- AppT <$> simplifyBareType' t1 <*> simplifyBareType' t2
-simplifyBareType'' ([], []) (RFun _ i o _) =
- (\x y -> ArrowT `AppT` x `AppT` y)
- <$> simplifyBareType' i <*> simplifyBareType' o
-simplifyBareType'' ([], []) (RApp cc as _ _) =
- let c = btc_tc cc
- c' | isFun c = ArrowT
- | isTuple c = TupleT (length as)
- | isList c = ListT
- | otherwise = ConT $ symbolName c
- in foldl' AppT c' <$> sequenceA (filterExprArgs $ simplifyBareType' <$> as)
-
-simplifyBareType'' _ (RExprArg e) =
- FoundExprArg $ fSrcSpan e
-simplifyBareType'' _ (RHole _) =
- FoundHole
-
-simplifyBareType'' s(RAllP _ t) =
- simplifyBareType'' s t
-simplifyBareType'' s (RAllE _ _ t) =
- simplifyBareType'' s t
-simplifyBareType'' s (REx _ _ t) =
- simplifyBareType'' s t
-simplifyBareType'' s (RRTy _ _ _ t) =
- simplifyBareType'' s t
-
-simplifyBareType'' (tvs, cls) (RFun _ i o _)
- | isClassType i = simplifyBareType'' (tvs, i : cls) o
-simplifyBareType'' (tvs, cls) (RAllT tv t _) =
- simplifyBareType'' (ty_var_value tv : tvs, cls) t
-
-simplifyBareType'' (tvs, cls) t =
- ForallT (PlainTV . symbolName <$> reverse tvs)
- <$> mapM simplifyBareType' (reverse cls)
- <*> simplifyBareType' t
-
-
-data Simpl a = Simplified a
- | FoundExprArg SrcSpan
- | FoundHole
- deriving (Functor)
-
-instance Applicative Simpl where
- pure = Simplified
-
- Simplified f <*> Simplified x = Simplified $ f x
- _ <*> FoundExprArg l = FoundExprArg l
- _ <*> FoundHole = FoundHole
- FoundExprArg l <*> _ = FoundExprArg l
- FoundHole <*> _ = FoundHole
-
-instance Monad Simpl where
- return = Simplified
-
- Simplified x >>= f = f x
- FoundExprArg l >>= _ = FoundExprArg l
- FoundHole >>= _ = FoundHole
-
-filterExprArgs :: [Simpl a] -> [Simpl a]
-filterExprArgs = filter check
- where
- check (FoundExprArg _) = False
- check _ = True
-
---------------------------------------------------------------------------------
--- QuasiQuoter Annotations -----------------------------------------------------
---------------------------------------------------------------------------------
-
-newtype LiquidQuote = LiquidQuote { liquidQuoteSpec :: BPspec }
- deriving (Data, Typeable)
-
---------------------------------------------------------------------------------
--- Template Haskell Utility Functions ------------------------------------------
---------------------------------------------------------------------------------
-
-locSourcePos :: Loc -> SourcePos
-locSourcePos loc =
- newPos (loc_filename loc) (fst $ loc_start loc) (snd $ loc_start loc)
-
-dataToExpQ' :: Data a => a -> Q Exp
-dataToExpQ' = dataToExpQ (const Nothing `extQ` textToExpQ)
-
-textToExpQ :: T.Text -> Maybe ExpQ
-textToExpQ text = Just $ varE 'T.pack `appE` stringE (T.unpack text)
-
-extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q
-extQ f g a = maybe (f a) g (cast a)
-
diff --git a/src/Language/Haskell/Liquid/UX/Tidy.hs b/src/Language/Haskell/Liquid/UX/Tidy.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/UX/Tidy.hs
+++ /dev/null
@@ -1,248 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances #-}
-
----------------------------------------------------------------------
--- | This module contains functions for cleaning up types before
--- they are rendered, e.g. in error messages or annoations,
--- and also some PPrint instances that rely upon tidying.
----------------------------------------------------------------------
-
-module Language.Haskell.Liquid.UX.Tidy (
-
- -- * Tidying functions
- tidySpecType
- , tidySymbol
-
- -- * Panic and Exit
- , panicError
-
- -- * Final result
- , Result (..)
-
- -- * Error to UserError
- , errorToUserError
-
- -- * MOVE TO TYPES
- , cinfoError
- ) where
-
-import Data.Hashable
-import Prelude hiding (error)
-import qualified Data.HashMap.Strict as M
-import qualified Data.HashSet as S
-import qualified Data.List as L
-import qualified Data.Text as T
-import qualified Control.Exception as Ex
-import qualified Language.Haskell.Liquid.GHC.Misc as GM
--- (dropModuleNames, showPpr, stringTyVar)
-import Language.Fixpoint.Types hiding (Result, SrcSpan, Error)
-import Language.Haskell.Liquid.Types.Types
-import Language.Haskell.Liquid.Types.RefType (rVar, subsTyVars_meet, FreeVar)
-import Language.Haskell.Liquid.Types.PrettyPrint
-import Data.Generics (everywhere, mkT)
-import Text.PrettyPrint.HughesPJ
-
-
-------------------------------------------------------------------------
--- | Converting Results To Answers -------------------------------------
-------------------------------------------------------------------------
-
-class Result a where
- result :: a -> FixResult UserError
-
-instance Result UserError where
- result e = Crash [e] ""
-
-instance Result [Error] where
- result es = Crash (errorToUserError <$> es) ""
-
-instance Result Error where
- result e = result [e] -- Crash [pprint e] ""
-
-instance Result (FixResult Cinfo) where
- result = fmap (errorToUserError . cinfoError)
-
-errorToUserError :: Error -> UserError
-errorToUserError = fmap ppSpecTypeErr
-
--- TODO: move to Types.hs
-cinfoError :: Cinfo -> Error
-cinfoError (Ci _ (Just e) _) = e
-cinfoError (Ci l _ _) = ErrOther l (text $ "Cinfo:" ++ GM.showPpr l)
-
--------------------------------------------------------------------------
-tidySpecType :: Tidy -> SpecType -> SpecType
--------------------------------------------------------------------------
-tidySpecType k
- = tidyEqual
- . tidyValueVars
- . tidyDSymbols
- . tidySymbols k
- . tidyInternalRefas
- . tidyLocalRefas k
- . tidyFunBinds
- . tidyTyVars
-
-tidyValueVars :: SpecType -> SpecType
-tidyValueVars = mapReft $ \u -> u { ur_reft = tidyVV $ ur_reft u }
-
-tidyVV :: Reft -> Reft
-tidyVV r@(Reft (va,_))
- | isJunk va = shiftVV r v'
- | otherwise = r
- where
- v' = if v `elem` xs then symbol ("v'" :: T.Text) else v
- v = symbol ("v" :: T.Text)
- xs = syms r
- isJunk = isPrefixOfSym "x"
-
-tidySymbols :: Tidy -> SpecType -> SpecType
-tidySymbols k t = substa (shortSymbol k . tidySymbol) $ mapBind dropBind t
- where
- xs = S.fromList (syms t)
- dropBind x = if x `S.member` xs then tidySymbol x else nonSymbol
-
-shortSymbol :: Tidy -> Symbol -> Symbol
-shortSymbol Lossy = GM.dropModuleNames
-shortSymbol _ = id
-
-tidyLocalRefas :: Tidy -> SpecType -> SpecType
-tidyLocalRefas k = mapReft (txReft' k)
- where
- txReft' Full = id
- txReft' Lossy = txReft
- txReft u = u { ur_reft = mapPredReft dropLocals $ ur_reft u }
- dropLocals = pAnd . filter (not . any isTmp . syms) . conjuncts
- isTmp x = any (`isPrefixOfSym` x) [anfPrefix, "ds_"]
-
-tidyEqual :: SpecType -> SpecType
-tidyEqual = mapReft txReft
- where
- txReft u = u { ur_reft = mapPredReft dropInternals $ ur_reft u }
- dropInternals = pAnd . L.nub . conjuncts
-
-tidyInternalRefas :: SpecType -> SpecType
-tidyInternalRefas = mapReft txReft
- where
- txReft u = u { ur_reft = mapPredReft dropInternals $ ur_reft u }
- dropInternals = pAnd . filter (not . any isIntern . syms) . conjuncts
- isIntern x = "is$" `isPrefixOfSym` x || "$select" `isSuffixOfSym` x
-
-
-tidyDSymbols :: SpecType -> SpecType
-tidyDSymbols t = mapBind tx $ substa tx t
- where
- tx = bindersTx [x | x <- syms t, isTmp x]
- isTmp = (tempPrefix `isPrefixOfSym`)
-
-tidyFunBinds :: SpecType -> SpecType
-tidyFunBinds t = mapBind tx $ substa tx t
- where
- tx = bindersTx $ filter GM.isTmpSymbol $ funBinds t
-
-tidyTyVars :: SpecType -> SpecType
-tidyTyVars t = subsTyVarsAll αβs t
- where
- αβs = zipWith (\α β -> (α, toRSort β, β)) αs βs
- αs = L.nub (tyVars t)
- βs = map (rVar . GM.stringTyVar) pool
- pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [1..]]
-
-
-bindersTx :: [Symbol] -> Symbol -> Symbol
-bindersTx ds = \y -> M.lookupDefault y y m
- where
- m = M.fromList $ zip ds $ var <$> [1..]
- var = symbol . ('x' :) . show
-
-
-tyVars :: RType c tv r -> [tv]
-tyVars (RAllP _ t) = tyVars t
-tyVars (RAllT α t _) = ty_var_value α : tyVars t
-tyVars (RImpF _ t t' _) = tyVars t ++ tyVars t'
-tyVars (RFun _ t t' _) = tyVars t ++ tyVars t'
-tyVars (RAppTy t t' _) = tyVars t ++ tyVars t'
-tyVars (RApp _ ts _ _) = concatMap tyVars ts
-tyVars (RVar α _) = [α]
-tyVars (RAllE _ _ t) = tyVars t
-tyVars (REx _ _ t) = tyVars t
-tyVars (RExprArg _) = []
-tyVars (RRTy _ _ _ t) = tyVars t
-tyVars (RHole _) = []
-
-subsTyVarsAll
- :: (Eq k, Hashable k,
- Reftable r, TyConable c, SubsTy k (RType c k ()) c,
- SubsTy k (RType c k ()) r,
- SubsTy k (RType c k ()) k,
- SubsTy k (RType c k ()) (RType c k ()),
- SubsTy k (RType c k ()) (RTVar k (RType c k ())),
- FreeVar c k)
- => [(k, RType c k (), RType c k r)] -> RType c k r -> RType c k r
-subsTyVarsAll ats = go
- where
- abm = M.fromList [(a, b) | (a, _, RVar b _) <- ats]
- go (RAllT a t r) = RAllT (makeRTVar $ M.lookupDefault (ty_var_value a) (ty_var_value a) abm) (go t) r
- go t = subsTyVars_meet ats t
-
-
-funBinds :: RType t t1 t2 -> [Symbol]
-funBinds (RAllT _ t _) = funBinds t
-funBinds (RAllP _ t) = funBinds t
-funBinds (RImpF b t1 t2 _) = b : funBinds t1 ++ funBinds t2
-funBinds (RFun b t1 t2 _) = b : funBinds t1 ++ funBinds t2
-funBinds (RApp _ ts _ _) = concatMap funBinds ts
-funBinds (RAllE b t1 t2) = b : funBinds t1 ++ funBinds t2
-funBinds (REx b t1 t2) = b : funBinds t1 ++ funBinds t2
-funBinds (RVar _ _) = []
-funBinds (RRTy _ _ _ t) = funBinds t
-funBinds (RAppTy t1 t2 _) = funBinds t1 ++ funBinds t2
-funBinds (RExprArg _) = []
-funBinds (RHole _) = []
-
-
---------------------------------------------------------------------------------
--- | Show an Error, then crash
---------------------------------------------------------------------------------
-panicError :: {-(?callStack :: CallStack) =>-} Error -> a
---------------------------------------------------------------------------------
-panicError = Ex.throw
-
--- ^ This function is put in this module as it depends on the Exception instance,
--- which depends on the PPrint instance, which depends on tidySpecType.
-
---------------------------------------------------------------------------------
--- | Pretty Printing Error Messages --------------------------------------------
---------------------------------------------------------------------------------
-
--- | Need to put @PPrint Error@ instance here (instead of in Types),
--- as it depends on @PPrint SpecTypes@, which lives in this module.
-
-
-instance PPrint (CtxError Doc) where
- pprintTidy k ce = ppError k (ctCtx ce) $ ctErr ce
-
-instance PPrint (CtxError SpecType) where
- pprintTidy k ce = ppError k (ctCtx ce) $ ppSpecTypeErr <$> ctErr ce
-
-instance PPrint Error where
- pprintTidy k = ppError k empty . fmap ppSpecTypeErr
-
-ppSpecTypeErr :: SpecType -> Doc
-ppSpecTypeErr = ppSpecType Lossy
-
-ppSpecType :: Tidy -> SpecType -> Doc
-ppSpecType k = rtypeDoc k
- . tidySpecType k
- . fmap (everywhere (mkT noCasts))
- where
- noCasts (ECst x _) = x
- noCasts e = e
-
-instance Show Error where
- show = showpp
-
-instance Ex.Exception Error
-instance Ex.Exception [Error]
diff --git a/src/Language/Haskell/Liquid/WiredIn.hs b/src/Language/Haskell/Liquid/WiredIn.hs
deleted file mode 100644
--- a/src/Language/Haskell/Liquid/WiredIn.hs
+++ /dev/null
@@ -1,214 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Language.Haskell.Liquid.WiredIn
- ( wiredTyCons
- , wiredDataCons
- , wiredSortedSyms
-
- -- * Constants for automatic proofs
- , dictionaryVar
- , dictionaryTyVar
- , dictionaryBind
- , proofTyConName
- , combineProofsName
-
- -- * Built in symbols
- , isWiredIn
- , isWiredInName
- , dcPrefix
-
- -- * Deriving classes
- , isDerivedInstance
- ) where
-
-import Prelude hiding (error)
-import Var
-
--- import Language.Fixpoint.Misc (mapSnd)
-import Language.Haskell.Liquid.GHC.Misc
-import qualified Language.Haskell.Liquid.GHC.API as Ghc
-import Language.Haskell.Liquid.Types.Types
-import Language.Haskell.Liquid.Types.RefType
-import Language.Haskell.Liquid.Types.Variance
-import Language.Haskell.Liquid.Types.PredType
-
--- import Language.Fixpoint.Types hiding (panic)
-import qualified Language.Fixpoint.Types as F
-import qualified Data.HashSet as S
-
-import BasicTypes
--- import DataCon
--- import TyCon
-import TysWiredIn
-
-import Language.Haskell.Liquid.GHC.TypeRep ()
-import CoreSyn hiding (mkTyArg)
-
--- | Horrible hack to support hardwired symbols like
--- `head`, `tail`, `fst`, `snd`
--- and other LH generated symbols that
--- *do not* correspond to GHC Vars and
--- *should not* be resolved to GHC Vars.
-
-isWiredIn :: F.LocSymbol -> Bool
-isWiredIn x = isWiredInLoc x || isWiredInName (val x) || isWiredInShape x
-
-isWiredInLoc :: F.LocSymbol -> Bool
-isWiredInLoc x = l == l' && l == 0 && c == c' && c' == 0
- where
- (l , c) = spe (loc x)
- (l', c') = spe (locE x)
- spe l = (x, y) where (_, x, y) = F.sourcePosElts l
-
-isWiredInName :: F.Symbol -> Bool
-isWiredInName x = x `S.member` wiredInNames
-
-wiredInNames :: S.HashSet F.Symbol
-wiredInNames = S.fromList [ "head", "tail", "fst", "snd", "len"]
-
-isWiredInShape :: F.LocSymbol -> Bool
-isWiredInShape x = any (`F.isPrefixOfSym` (val x)) [F.anfPrefix, F.tempPrefix, dcPrefix]
- -- where s = val x
- -- dcPrefix = "lqdc"
-
-dcPrefix :: F.Symbol
-dcPrefix = "lqdc"
-
-wiredSortedSyms :: [(F.Symbol, F.Sort)]
-wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]]
-
---------------------------------------------------------------------------------
--- | LH Primitive TyCons -------------------------------------------------------
---------------------------------------------------------------------------------
-
-dictionaryVar :: Var
-dictionaryVar = stringVar "tmp_dictionary_var" (Ghc.ForAllTy (Ghc.Bndr dictionaryTyVar Required) $ Ghc.TyVarTy dictionaryTyVar)
-
-dictionaryTyVar :: TyVar
-dictionaryTyVar = stringTyVar "da"
-
-dictionaryBind :: Bind Var
-dictionaryBind = Rec [(v, Lam a $ App (Var v) (Type $ Ghc.TyVarTy a))]
- where
- v = dictionaryVar
- a = dictionaryTyVar
-
------------------------------------------------------------------------
--- | LH Primitive TyCons ----------------------------------------------
------------------------------------------------------------------------
-
-
-combineProofsName :: String
-combineProofsName = "combineProofs"
-
-proofTyConName :: F.Symbol
-proofTyConName = "Proof"
-
---------------------------------------------------------------------------------
--- | Predicate Types for WiredIns ----------------------------------------------
---------------------------------------------------------------------------------
-
-maxArity :: Arity
-maxArity = 7
-
-wiredTyCons :: [TyConP]
-wiredTyCons = fst wiredTyDataCons
-
-wiredDataCons :: [Located DataConP]
-wiredDataCons = snd wiredTyDataCons
-
-wiredTyDataCons :: ([TyConP] , [Located DataConP])
-wiredTyDataCons = (concat tcs, dummyLoc <$> concat dcs)
- where
- (tcs, dcs) = unzip $ listTyDataCons : map tupleTyDataCons [2..maxArity]
-
-listTyDataCons :: ([TyConP] , [DataConP])
-listTyDataCons = ( [(TyConP l0 c [RTV tyv] [p] [Covariant] [Covariant] (Just fsize))]
- , [(DataConP l0 nilDataCon [RTV tyv] [p] [] [] lt False wiredInName l0)
- ,(DataConP l0 consDataCon [RTV tyv] [p] [] cargs lt False wiredInName l0)])
- where
- l0 = F.dummyPos "LH.Bare.listTyDataCons"
- c = listTyCon
- [tyv] = tyConTyVarsDef c
- t = rVar tyv :: RSort
- fld = "fldList"
- xHead = "head"
- xTail = "tail"
- p = PV "p" (PVProp t) (F.vv Nothing) [(t, fld, F.EVar fld)]
- px = pdVarReft $ PV "p" (PVProp t) (F.vv Nothing) [(t, fld, F.EVar xHead)]
- lt = rApp c [xt] [rPropP [] $ pdVarReft p] mempty
- xt = rVar tyv
- xst = rApp c [RVar (RTV tyv) px] [rPropP [] $ pdVarReft p] mempty
- cargs = [(xTail, xst), (xHead, xt)]
- fsize = SymSizeFun (dummyLoc "len")
-
-wiredInName :: F.Symbol
-wiredInName = "WiredIn"
-
-tupleTyDataCons :: Int -> ([TyConP] , [DataConP])
-tupleTyDataCons n = ( [(TyConP l0 c (RTV <$> tyvs) ps tyvarinfo pdvarinfo Nothing)]
- , [(DataConP l0 dc (RTV <$> tyvs) ps [] cargs lt False wiredInName l0)])
- where
- tyvarinfo = replicate n Covariant
- pdvarinfo = replicate (n-1) Covariant
- l0 = F.dummyPos "LH.Bare.tupleTyDataCons"
- c = tupleTyCon Boxed n
- dc = tupleDataCon Boxed n
- tyvs@(tv:tvs) = tyConTyVarsDef c
- (ta:ts) = (rVar <$> tyvs) :: [RSort]
- flds = mks "fld_Tuple"
- fld = "fld_Tuple"
- x1:xs = mks ("x_Tuple" ++ show n)
- ps = mkps pnames (ta:ts) ((fld, F.EVar fld) : zip flds (F.EVar <$> flds))
- ups = uPVar <$> ps
- pxs = mkps pnames (ta:ts) ((fld, F.EVar x1) : zip flds (F.EVar <$> xs))
- lt = rApp c (rVar <$> tyvs) (rPropP [] . pdVarReft <$> ups) mempty
- xts = zipWith (\v p -> RVar (RTV v) (pdVarReft p)) tvs pxs
- cargs = reverse $ (x1, rVar tv) : zip xs xts
- pnames = mks_ "p"
- mks x = (\i -> F.symbol (x++ show i)) <$> [1..n]
- mks_ x = (\i -> F.symbol (x++ show i)) <$> [2..n]
-
-
-mkps :: [F.Symbol]
- -> [t] -> [(F.Symbol, F.Expr)] -> [PVar t]
-mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ ns ts fxs [(t, f, x)] []
-mkps _ _ _ = panic Nothing "Bare : mkps"
-
-mkps_ :: [F.Symbol]
- -> [t]
- -> [(F.Symbol, F.Expr)]
- -> [(t, F.Symbol, F.Expr)]
- -> [PVar t]
- -> [PVar t]
-mkps_ [] _ _ _ ps = ps
-mkps_ (n:ns) (t:ts) ((f, x):xs) args ps = mkps_ ns ts xs (a:args) (p:ps)
- where
- p = PV n (PVProp t) (F.vv Nothing) args
- a = (t, f, x)
-mkps_ _ _ _ _ _ = panic Nothing "Bare : mkps_"
-
-
---------------------------------------------------------------------------------
-isDerivedInstance :: Ghc.ClsInst -> Bool
---------------------------------------------------------------------------------
-isDerivedInstance i = F.notracepp ("IS-DERIVED: " ++ F.showpp classSym)
- $ S.member classSym derivingClasses
- where
- classSym = F.symbol . Ghc.is_cls $ i
-
-derivingClasses :: S.HashSet F.Symbol
-derivingClasses = S.fromList
- [ "GHC.Classes.Eq"
- , "GHC.Classes.Ord"
- , "GHC.Enum.Enum"
- , "GHC.Show.Show"
- , "GHC.Read.Read"
- , "GHC.Base.Monad"
- , "GHC.Base.Applicative"
- , "GHC.Base.Functor"
- , "Data.Foldable.Foldable"
- , "Data.Traversable.Traversable"
- -- , "GHC.Enum.Bounded"
- -- , "GHC.Base.Monoid"
- ]
diff --git a/src/Liquid/Prelude/Real_LHAssumptions.hs b/src/Liquid/Prelude/Real_LHAssumptions.hs
new file mode 100644
--- /dev/null
+++ b/src/Liquid/Prelude/Real_LHAssumptions.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -fplugin=LiquidHaskellBoot #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+module Liquid.Prelude.Real_LHAssumptions where
+
+{-@
+assume * :: Num a => x:a -> y:a -> {v:a | v = x * y}
+@-}
diff --git a/src/Liquid/Prelude/Totality_LHAssumptions.hs b/src/Liquid/Prelude/Totality_LHAssumptions.hs
new file mode 100644
--- /dev/null
+++ b/src/Liquid/Prelude/Totality_LHAssumptions.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fplugin=LiquidHaskellBoot #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+module Liquid.Prelude.Totality_LHAssumptions where
+
+import Control.Exception.Base
+import GHC.Prim
+
+{-@
+measure totalityError :: a -> Bool
+
+assume patError :: {v:Addr# | totalityError "Pattern match(es) are non-exhaustive"} -> a
+
+assume recSelError :: {v:Addr# | totalityError "Use of partial record field selector"} -> a
+
+assume nonExhaustiveGuardsError :: {v:Addr# | totalityError "Guards are non-exhaustive"} -> a
+
+assume noMethodBindingError :: {v:Addr# | totalityError "Missing method(s) on instance declaration"} -> a
+
+assume recConError :: {v:Addr# | totalityError "Missing field in record construction"} -> a
+@-}
diff --git a/src/LiquidHaskell.hs b/src/LiquidHaskell.hs
--- a/src/LiquidHaskell.hs
+++ b/src/LiquidHaskell.hs
@@ -1,20 +1,4 @@
-{-# LANGUAGE CPP #-}
-
-module LiquidHaskell (
- -- * LiquidHaskell Specification QuasiQuoter
- lq
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
- -- * LiquidHaskell as a compiler plugin
- , plugin
-#endif
-#endif
- ) where
-
-import Language.Haskell.Liquid.UX.QuasiQuoter
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
+module LiquidHaskell (plugin, lq) where
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
-import Language.Haskell.Liquid.GHC.Plugin (plugin)
-#endif
-#endif
+import LiquidHaskellBoot(plugin, lq)
diff --git a/src/Prelude_LHAssumptions.hs b/src/Prelude_LHAssumptions.hs
new file mode 100644
--- /dev/null
+++ b/src/Prelude_LHAssumptions.hs
@@ -0,0 +1,64 @@
+{-# OPTIONS_GHC -fplugin=LiquidHaskellBoot #-}
+module Prelude_LHAssumptions where
+
+import Data.Foldable_LHAssumptions()
+import Data.List_LHAssumptions()
+import GHC.Base_LHAssumptions()
+import GHC.Classes_LHAssumptions()
+import GHC.Float_LHAssumptions()
+import GHC.Maybe_LHAssumptions()
+import GHC.Num_LHAssumptions()
+import GHC.Num.Integer_LHAssumptions()
+import GHC.Real_LHAssumptions()
+import Liquid.Prelude.Real_LHAssumptions()
+import Liquid.Prelude.Totality_LHAssumptions()
+
+{-@
+
+assume error :: {v:_ | false} -> a
+
+predicate Max V X Y = if X > Y then V = X else V = Y
+predicate Min V X Y = if X < Y then V = X else V = Y
+
+type IncrListD a D = [a]<{\x y -> (x+D) <= y}>
+
+// BOT: Do not delete EVER!
+
+qualif Bot(v:@(0)) { 0 = 1 }
+qualif Bot(v:obj) { 0 = 1 }
+qualif Bot(v:a) { 0 = 1 }
+qualif Bot(v:bool) { 0 = 1 }
+qualif Bot(v:int) { 0 = 1 }
+
+qualif CmpZ(v:a) { v < 0 }
+qualif CmpZ(v:a) { v <= 0 }
+qualif CmpZ(v:a) { v > 0 }
+qualif CmpZ(v:a) { v >= 0 }
+qualif CmpZ(v:a) { v = 0 }
+qualif CmpZ(v:a) { v != 0 }
+
+qualif Cmp(v:a, x:a) { v < x }
+qualif Cmp(v:a, x:a) { v <= x }
+qualif Cmp(v:a, x:a) { v > x }
+qualif Cmp(v:a, x:a) { v >= x }
+qualif Cmp(v:a, x:a) { v = x }
+qualif Cmp(v:a, x:a) { v != x }
+
+qualif One(v:int) { v = 1 }
+qualif True1(v:Bool) { v }
+qualif False1(v:Bool) { ~ v }
+
+// REBARE constant papp1 : func(1, [Pred @(0); @(0); bool])
+qualif Papp(v:a, p:Pred a) { papp1 p v }
+
+// REBARE constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool])
+qualif Papp2(v:a, x:b, p:Pred a b) { papp2 p v x }
+
+// REBARE constant papp3 : func(6, [Pred @(0) @(1) @(2); @(3); @(4); @(5); bool])
+qualif Papp3(v:a, x:b, y:c, p:Pred a b c) { papp3 p v x y }
+
+// qualif Papp4(v:a,x:b, y:c, z:d, p:Pred a b c d) : papp4(p, v, x, y, z)
+// REBARE constant papp4 : func(8, [Pred @(0) @(1) @(2) @(6); @(3); @(4); @(5); @(7); bool])
+
+// REBARE constant runFun : func(2, [Arrow @(0) @(1); @(0); @(1)])
+@-}
diff --git a/syntax/liquid.css b/syntax/liquid.css
deleted file mode 100644
--- a/syntax/liquid.css
+++ /dev/null
@@ -1,105 +0,0 @@
-.hs-linenum {
- color: #B2B2B2;
- font-style: italic;
-}
-
-.hs-error {
- background-color: #FF8585 ;
-}
-
-.hs-keyglyph {
- color: #007020
-}
-
-.hs-keyword {
- color: #007020;
- // font-weight: bold;
-}
-
-.hs-comment, .hs-comment a {color: green;}
-
-.hs-str, .hs-chr {color: teal;}
-
-.hs-conid {
- color: #902000; /* color: #00FFFF; color: #0E84B5; */
- //font-weight: bold;
-}
-
-.hs-definition {
- color: #06287E
- /* font-weight: bold; */
-}
-
-.hs-varid, .hs-varop, .hs-layout {
- color: black;
-}
-
-.hs-num {
- color: #40A070;
-}
-
-.hs-conop {
- color: #902000;
-}
-
-.hs-cpp {
- color: orange;
-}
-
-.hs-sel {}
-
-a.annot {
- position:relative;
- color:#000;
- text-decoration:none;
- white-space: pre;
-}
-
-a.annot:hover {
- z-index:25;
- background-color: #D8D8D8;
-}
-
-a.annot span.annottext{display: none}
-
-a.annot:hover span.annottext{
-
- border-radius: 5px 5px;
-
- -moz-border-radius: 5px;
- -webkit-border-radius: 5px;
-
- box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1);
- -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);
- -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);
-
- white-space:pre;
- display:block;
- position: absolute;
- left: 1em; top: 2em;
- z-index: 99;
- margin-left: 5;
- background: #FFFFAA;
- border: 3px solid #FFAD33;
- padding: 0.8em 1em;
-}
-
-code {
- /* font-weight: bold; */
- background-color: rgb(250, 250, 250);
- border: 1px solid rgb(200, 200, 200);
- padding-left: 4px;
- padding-right: 4px;
-}
-
-pre {
- background-color: #f0f0f0;
- border-top: 1px solid #ccc;
- border-bottom: 1px solid #ccc;
- padding: 5px;
- // font-size: 120%;
- // font-family: Bitstream Vera Sans Mono,monospace;
- display: block;
- overflow: visible;
-}
-
diff --git a/tests/Parser.hs b/tests/Parser.hs
deleted file mode 100644
--- a/tests/Parser.hs
+++ /dev/null
@@ -1,529 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | Simple test suite to test the parser.
---
--- Run as:
---
--- $ stack test :liquidhaskell-parser
-
-module Main where
-
-import Data.Data
-import Data.Char (isSpace)
-import Data.Generics.Aliases
-import Data.Generics.Schemes
-
-import Language.Fixpoint.Types.Spans
-import qualified Language.Haskell.Liquid.Parse as LH
-import qualified Language.Fixpoint.Types as F
-
-import Text.Parsec.Pos
-import Test.Tasty
-import Test.Tasty.HUnit
-import Test.Tasty.Runners.AntXML
-
--- ---------------------------------------------------------------------
-
--- | Test suite entry point, returns exit failure if any test fails.
-main :: IO ()
--- main = do
--- print $ parseSingleSpec "type IncrListD a D = [a]<{\\x y -> (x+D) <= y}>"
--- return ()
-main = defaultMainWithIngredients (
- antXMLRunner:defaultIngredients
- ) tests
-
-tests :: TestTree
-tests =
- testGroup "ParserTests"
- [ testSucceeds
- , testSpecP
- , testReservedAliases
- , testFails
- , testErrorReporting
- ]
-
--- ---------------------------------------------------------------------
-
--- Test that the top level production works, each of the sub-elements will be tested separately
-testSpecP :: TestTree
-testSpecP =
- testGroup "specP"
- [ testCase "assume" $
- parseSingleSpec "assume foo :: a -> a " @?==
- "assume foo :: lq_tmp$db##0:a -> a"
-
- , testCase "assert" $
- parseSingleSpec "assert myabs :: Int -> PosInt" @?==
- "assert myabs :: lq_tmp$db##0:Int -> PosInt"
-
- , testCase "autosize" $
- parseSingleSpec "autosize List" @?==
- "autosize List"
-
- , testCase "local" $
- parseSingleSpec "local foo :: Nat -> Nat" @?==
- "local assert foo :: lq_tmp$db##0:Nat -> Nat"
-
- , testCase "axiomatize" $
- parseSingleSpec "axiomatize fibA" @?==
- "reflect fibA"
-
- , testCase "reflect" $
- parseSingleSpec "reflect map" @?==
- "reflect map"
-
- , testCase "measure HMeas" $
- parseSingleSpec "measure isAbs" @?==
- "measure isAbs"
-
- , testCase "measure Meas" $
- parseSingleSpec "measure fv :: Expr -> (Set Bndr)" @?==
- "measure fv :: lq_tmp$db##0:Expr -> (Set Bndr)"
-
- , testCase "define" $
- parseSingleSpec "define $ceq = eqN" @?==
- "define $ceq = eqN"
-
- , testCase "infixl" $
- parseSingleSpec "infixl 9 +++" @?==
- "fixity"
-
- , testCase "infixr" $
- parseSingleSpec "infixr 9 +++" @?==
- "fixity"
-
- , testCase "infix" $
- parseSingleSpec "infix 9 +++" @?==
- "fixity"
-
- , testCase "inline" $
- parseSingleSpec "inline eqelems" @?==
- "inline eqelems"
-
- , testCase "bound PBound" $
- parseSingleSpec "bound Foo = true" @?==
- "bound Foo forall [] . [] = true"
-
- , testCase "bound HBound" $
- parseSingleSpec "bound step" @?==
- "bound step"
-
- , testCase "class measure" $
- parseSingleSpec "class measure sz :: forall a. a -> Int" @?==
- "class measure sz :: forall a . lq_tmp$db##0:a -> Int"
-
- , testCase "instance measure" $
- parseSingleSpec "instance measure sz :: MList a -> Int" @?==
- "instance measure sz :: lq_tmp$db##0:(MList a) -> Int"
-
- , testCase "instance" $
- parseSingleSpec "instance VerifiedNum Int where\n - :: x:Int -> y:Int -> OkInt {x - y} " @?==
- "instance (VerifiedNum Int) where\n - :: x:Int -> y:Int -> (OkInt {x - y})"
-
- , testCase "class" $
- parseSingleSpec "class Sized s where\n size :: forall a. x:s a -> {v:Nat | v = sz x}" @?==
- "class (Sized s) where\n size :: forall a . x:s a -> {v : Nat | v == sz x}"
-
- , testCase "import" $
- parseSingleSpec "import Foo" @?==
- "import Foo"
-
- , testCase "data variance" $
- parseSingleSpec "data variance IO bivariant" @?==
- "data variance IO Bivariant"
-
- , testCase "data" $
- parseSingleSpec "data Bob = B {foo :: Int}" @?==
- "data Bob [] =\n | B :: forall . foo : Int -> *"
-
- , testCase "newtype" $
- parseSingleSpec "newtype Foo = Bar {x :: Nat}" @?==
- "newtype data Foo [] =\n | Bar :: forall . x : Nat -> *"
-
- , testCase "include" $
- parseSingleSpec "include <: {v:a| x <= v}} "
- , " {a
<: a
) -> OList a
| true} <: {v : a | x <= v}} =>\n {|- {VV : a
| true} <: {VV : a
| true}) -> (OList {VV : a
<: Int
|- {v:Int| v = x + 1} <: Int
}"
- , " (Int
-> ()" ])
- @?==
- "app :: forall
| true}>) <: (Int <{VV : _
| true}>) |- {v : Int | v == x + 1} <: (Int <{VV : _
| true}>)} =>\n lq_tmp$db##8:(lq_tmp$db##9:(Int <{VV : _
| true}>) -> ()"
-
- , testCase "type spec 12" $
- parseSingleSpec (unlines $
- [ " ssum :: forall
}"
- , " {x::a
}"
- , " xs:[{v:a
| len xs >= 0 && 0 <= v } "])
- @?==
- "ssum :: forall
| true}} =>\n {x :: {VV : a
| true}} =>\n xs:[{v : a
| len xs >= 0\n && 0 <= v}"
-
- , testCase "type spec 13" $
- parseSingleSpec (unlines $
- [ " predicate ValidChunk V XS N "
- , " = if len XS == 0 "
- , " then (len V == 0) "
- , " else (((1 < len XS && 1 < N) => (len V < len XS)) "
- , " && ((len XS <= N ) => len V == 1)) "])
- @?==
- "predicate ValidChunk V XS N = (len XS == 0 => len V == 0)\n && (not (len XS == 0) => (1 < len XS\n && 1 < N => len V < len XS)\n && (len XS <= N => len V == 1))"
-
-
- , testCase "type spec 14" $
- parseSingleSpec "assume (=*=.) :: Arg a => f:(a -> b) -> g:(a -> b) -> (r:a -> {f r == g r}) -> {v:(a -> b) | f == g}" @?==
- "assume (=*=.) :: (Arg a) -> f:(lq_tmp$db##1:a -> b) -> g:(lq_tmp$db##3:a -> b) -> lq_tmp$db##5:(r:a -> {VV : _ | f r == g r}) -> lq_tmp$db##6:a -> b"
-
- , testCase "type spec 15" $
- parseSingleSpec "sort :: (Ord a) => xs:[a] -> OListN a {len xs}" @?==
- "sort :: (Ord a) -> xs:[a] -> (OListN a {len xs})"
-
- , testCase "type spec 16" $
- parseSingleSpec " ==. :: x:a -> y:{a| x == y} -> {v:b | v ~~ x && v ~~ y } " @?==
- "==. :: x:a -> y:{y : a | x == y} -> {v : b | v ~~ x\n && v ~~ y}"
-
- , testCase "type spec 17" $
- parseSingleSpec "measure snd :: (a,b) -> b" @?==
- "measure snd :: lq_tmp$db##0:(a, b) -> b"
-
- , testCase "type spec 18" $
- parseSingleSpec "returnST :: xState:a \n -> ST <{\\xs xa v -> (xa = xState)}> a s " @?==
- "returnST :: xState:a -> (ST <\\xs##1 xa##2 VV -> {v##3 : LIQUID$dummy | xa##2 == xState}> a s)"
-
- , testCase "type spec 19" $
- parseSingleSpec "makeq :: l:_ -> r:{ _ | size r <= size l + 1} -> _ " @?==
- "makeq :: l:{VV : _ | $HOLE} -> r:{r : _ | size r <= size l + 1} -> {VV : _ | $HOLE}"
-
- , testCase "type spec 21" $
- parseSingleSpec "newRGRef :: forall
Int -> Bool> = X (x0 :: Int) (x1 :: Int
) @-}
-data X = X Int Int
-
-{-@ data T
Bool>.
- { zoo::Int |- Int <: {v:Int | 0 <= v} }
- ST )
- @-}
-
-{- fresh :: ST <{\v -> (0 <= v)}, {\rv v -> ( 0 <= rv && rv + 1 = v )}> Int Nat @-}
-fresh :: ST Int Int
-fresh = S (\n -> (n, n+1))
-
---------------------------------------------------------------------------------
-
-{-@ incr0 :: ST <{\v -> (0 <= v)}, {\rv v -> (0 <= rv && 1 <= v)}> Int Int @-}
-incr0 :: ST Int Int
-incr0 = do
- n <- fresh
- return n
-
-{-@ incr1 :: ST <{\v -> (0 <= v)}, {\rv v -> (0 <= rv && 1 <= v)}> Int Int @-}
-incr1 :: ST Int Int
-incr1 = fresh >>= return
-
-{-@ incr2 :: ST <{\v -> (0 == v)}, {\rv v -> (4 == v)}> Int Int @-}
-incr2 :: ST Int Int
-incr2 = do
- n0 <- fresh
- n1 <- fresh
- n2 <- fresh
- n3 <- fresh
- return (checkEq 3 n3)
-
-{-@ checkEq :: x:Int -> y:{Int | y = x} -> {v:Int | v = y} @-}
-checkEq :: Int -> Int -> Int
-checkEq x y = y
diff --git a/tests/import/client/T1096_Foo.hs b/tests/import/client/T1096_Foo.hs
deleted file mode 100644
--- a/tests/import/client/T1096_Foo.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module T1096_Foo where
-
-import T1096_Types
-
-{-@ foo :: f:Foo -> Foo / [size f] @-}
-foo :: Foo -> Foo
-foo (A x) = A (foo x)
-foo x = x
diff --git a/tests/import/client/T1104Client.hs b/tests/import/client/T1104Client.hs
deleted file mode 100644
--- a/tests/import/client/T1104Client.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module T1104Client where
-
-import T1104Lib
-
--- 'bar' should ALSO work but right now, but right now 'twerp' is simpler.
-
-{- bar :: Foo a b -> Maybe ({v:Foo a b | isFoo v}) @-}
-bar :: Foo a b -> Maybe (Foo a b)
-bar x | isFoo x = Just x
- | otherwise = Nothing
-
-{-@ burp :: (Foo a b) -> Nat @-}
-burp :: Foo a b -> Int
-burp x = toNat x
-
-{-@ twerp :: x:(Foo a b) -> {v:Bool | v = isFoo x} @-}
-twerp x = g x
- where
- g = isFoo
diff --git a/tests/import/client/T1117.hs b/tests/import/client/T1117.hs
deleted file mode 100644
--- a/tests/import/client/T1117.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-
-module T1117 where
-
-import T1117Lib
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ axiomatize leqU1 @-}
-leqU1 :: U1 p -> U1 p -> Bool
-leqU1 _ _ = True
-
-{-@ leqU1Refl :: x:U1 p -> { leqU1 x x } @-}
-leqU1Refl :: U1 p -> Proof
-leqU1Refl U1 = leqU1 U1 U1 === True *** QED
-
-{-@ axiomatize leqProd @-}
-leqProd :: Eq (f p)
- => (f p -> f p -> Bool) -> (g p -> g p -> Bool)
- -> Product f g p -> Product f g p -> Bool
-leqProd leqFP leqGP (Product x1 y1) (Product x2 y2) =
- if x1 == x2
- then leqGP y1 y2
- else leqFP x1 x2
-{-# INLINE leqProd #-}
diff --git a/tests/import/client/T1118.hs b/tests/import/client/T1118.hs
deleted file mode 100644
--- a/tests/import/client/T1118.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-
-module T1118 where
-
-import T1118Lib2
-import T1118Lib1
-
-import Language.Haskell.Liquid.ProofCombinators
-
-{-@ reflect leqU1 @-}
-leqU1 :: U1 p -> U1 p -> Bool
-leqU1 _ _ = True
-
-{-@ leqU1Refl :: x:U1 p -> { leqU1 x x } @-}
-leqU1Refl :: U1 p -> Proof
-leqU1Refl U1 = leqU1 U1 U1 === True *** QED
-
-{-@ reflect leqProd @-}
-leqProd :: Eq (f p)
- => (f p -> f p -> Bool) -> (g p -> g p -> Bool)
- -> Product f g p -> Product f g p -> Bool
-leqProd leqFP leqGP (Product x1 y1) (Product x2 y2) =
- if x1 == x2
- then leqGP y1 y2
- else leqFP x1 x2
-{-# INLINE leqProd #-}
diff --git a/tests/import/client/T1180.hs b/tests/import/client/T1180.hs
deleted file mode 100644
--- a/tests/import/client/T1180.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-{-@ LIQUID "--exact-data-con" @-}
-{-@ LIQUID "--noadt" @-}
-
-module Ev where
-
-import Peano
-
-pInt :: Peano -> Int
-pInt Z = 0
-pInt (S n) = 1 + pInt n
diff --git a/tests/import/client/T1688.hs b/tests/import/client/T1688.hs
deleted file mode 100644
--- a/tests/import/client/T1688.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-{-@ LIQUID "--reflection" @-}
-
-module T1688 where
-
-import T1688Lib
-
-data HasFType where
- FTBC :: Bool -> HasFType
-
-{-@ ftypSize :: HasFType -> { n:Int | n >= 0 } @-}
-ftypSize :: HasFType -> Int
-ftypSize (FTBC {}) = 1
diff --git a/tests/import/client/WrapClient.hs b/tests/import/client/WrapClient.hs
deleted file mode 100644
--- a/tests/import/client/WrapClient.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module WrapClient where
-
-import WrapLib
-import WrapLibCode
-
-{-@ bar :: {v:Int | v = 2 } @-}
-bar = foo 1
-
diff --git a/tests/import/lib/ExactGADT8.hs b/tests/import/lib/ExactGADT8.hs
deleted file mode 100644
--- a/tests/import/lib/ExactGADT8.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-@ LIQUID "--reflection" @-}
-{-@ LIQUID "--no-adt" @-}
-
-{-# LANGUAGE ExistentialQuantification, KindSignatures, TypeFamilies, GADTs #-}
-
---------------------------------------------------------------------------------
-module ExactGADT8 where
-
-class PersistEntity record where
- data EntityField record :: * -> *
-
-{-@ data Blob = Bingo { xVal :: Int, yVal :: Int } @-}
-data Blob = Bingo { xVal :: Int, yVal :: Int }
-
-instance PersistEntity Blob where
- data EntityField Blob typ where
- BlobXVal :: EntityField Blob Int
- BlobYVal :: EntityField Blob Int
-
-data RefinedFilter record typ = RefinedFilter
- { refinedFilterField :: EntityField record typ
- }
-
-evalQBlob :: RefinedFilter Blob typ -> Blob -> Bool
-evalQBlob filter blob = case refinedFilterField filter of
- BlobXVal -> True
- BlobYVal -> True
-
-{-@ reflect foo @-}
-foo :: RefinedFilter Blob typ -> Blob -> Bool
-foo (RefinedFilter BlobXVal) blob = True
-foo (RefinedFilter BlobYVal) blob = True
diff --git a/tests/import/lib/FunClashLib.hs b/tests/import/lib/FunClashLib.hs
deleted file mode 100644
--- a/tests/import/lib/FunClashLib.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module FunClashLib (blob) where
-
-import FunClashLibLib
-
-{-@ blob :: Nat -> Nat @-}
-blob :: Int -> Int
-blob = incr
-
diff --git a/tests/import/lib/FunClashLibLib.hs b/tests/import/lib/FunClashLibLib.hs
deleted file mode 100644
--- a/tests/import/lib/FunClashLibLib.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-
-module FunClashLibLib where
-
-{-@ incr :: Nat -> Nat @-}
-incr :: Int -> Int
-incr x = x + 1
diff --git a/tests/import/lib/LibAliasGen00.hs b/tests/import/lib/LibAliasGen00.hs
deleted file mode 100644
--- a/tests/import/lib/LibAliasGen00.hs
+++ /dev/null
@@ -1,10 +0,0 @@
--- Tests that we DON'T generalize type aliases before normalizing
-
-module LibAliasGen00 where
-
-{-@ type Floo a N = {v:[a] | len v = N} @-}
-
-{-@ assume foo :: n:Nat -> Floo Int n @-}
-foo :: Int -> [Int]
-foo _ = undefined
-
diff --git a/tests/import/lib/LibBlue.hs b/tests/import/lib/LibBlue.hs
deleted file mode 100644
--- a/tests/import/lib/LibBlue.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module LibBlue where
-
-data Thing = ThingBlue Int
-
-{-@ foo :: Int -> Thing @-}
-foo :: Int -> Thing
-foo = ThingBlue
-
diff --git a/tests/import/lib/LibRed.hs b/tests/import/lib/LibRed.hs
deleted file mode 100644
--- a/tests/import/lib/LibRed.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module LibRed where
-
-data Thing = ThingRed Int
-
-{-@ foo :: Int -> Thing @-}
-foo :: Int -> Thing
-foo = ThingRed
-
diff --git a/tests/import/lib/LiquidArray.hs b/tests/import/lib/LiquidArray.hs
deleted file mode 100644
--- a/tests/import/lib/LiquidArray.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-module LiquidArray where
-
-{-@ set :: forall a Bool, post :: a -> s -> Bool>
- = S { runSt :: (x:s -> ((a, s)
- @-}
-apply :: ST s a -> s -> (a, s)
-apply (S f) s = f s
-
-instance Functor (ST s) where
- fmap = undefined
-
-instance Applicative (ST s) where
- pure = undefined
- (<*>) = undefined
-
-instance Monad (ST s) where
- {-@ instance Monad (ST s) where
- return :: forall
|- a <: {v:a | x <= y} }
- Ord a =>
- [a
] -> Bool @-}
-mycmp :: Ord a => [a] -> [a] -> Bool
-mycmp (x:_) (_:y:_) = liquidAssert (x <= y) True
-
-
-{-@ mycmp' :: forall
|- a <: {v:a | x <= y} }
- Ord a =>
- a
-> Bool @-}
-mycmp' :: Ord a => a -> a -> Bool
-mycmp' x y = liquidAssert (x <= y) True
-
-bar :: Bool
-bar = let w = choose 0 in
- let x = w + 1 in
- let y = w - 1 in
- let z = w + 2 in
- mycmp [x, y, x, z] [z, x, z]
-
-
-bar' :: Bool
-bar' = let w = choose 0 in
- let x = w + 1 in
- let y = w - 1 in
- let z = w + 2 in
- mycmp' z y
diff --git a/tests/neg/Constraints.hs b/tests/neg/Constraints.hs
deleted file mode 100644
--- a/tests/neg/Constraints.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-module Compose where
-
-{-@
-cmp :: forall < pref :: b -> Bool, postf :: b -> c -> Bool
- , pre :: a -> Bool, postg :: a -> b -> Bool
- , post :: a -> c -> Bool
- >.
- {xx::a
, w::b
|- b
-> b
-> c
<: {v:a| x <= v}}
- {a
<: a
) -> OList a
) @-}
-
- {-@ runState :: forall
@-}
-
-
-
-{-@
-cmp :: forall < pref :: s -> Bool, postf :: s -> s -> Bool
- , pre :: s -> Bool, postg :: s -> s -> Bool
- , post :: s -> s -> Bool
- >.
- {xx::s
, w::s
|- s
)) @-}
-
-{-@ runState :: forall
) @-}
-
-
-class Monad m where
- return :: a -> m a
- (>>=) :: m a -> (a -> m b) -> m b
- (>>) :: m a -> m b -> m b
-
-instance Monad (ST s) where
- {-@ instance Monad ST s where
- return :: forall s a
|- a
, y::s
, w::s
|- s