diff --git a/docs/mkDocs/docs/options.md b/docs/mkDocs/docs/options.md index f4d06a87b..593bcf213 100644 --- a/docs/mkDocs/docs/options.md +++ b/docs/mkDocs/docs/options.md @@ -500,6 +500,23 @@ worse = bad (Very bad) Note that all positive occurrences are permited, unlike Coq that only allows the strictly positive ones (see: https://vilhelms.github.io/posts/why-must-inductive-types-be-strictly-positive/) +## Refined data constructors + +**Options:** `allow-unsafe-constructors` +By **default** only safe data constructor refinements are allowed. + +Allows the user to refine the return type of a data constructor with arbitrary refinements, also unsafe ones. + +```haskell +data F where + {-@ MkF :: { _:F | false } @-} + MkF :: F + +{-@ bad :: { false } @-} +bad :: F +bad = () ? MkF +``` + ## Total Haskell **Options:** `total-Haskell` diff --git a/liquid-prelude/src/Language/Haskell/Liquid/ProofCombinators.hs b/liquid-prelude/src/Language/Haskell/Liquid/ProofCombinators.hs index 7774cdd23..ade17e677 100644 --- a/liquid-prelude/src/Language/Haskell/Liquid/ProofCombinators.hs +++ b/liquid-prelude/src/Language/Haskell/Liquid/ProofCombinators.hs @@ -76,7 +76,9 @@ _ *** _ = () data QED = Admit | QED {-@ measure isAdmit :: QED -> Bool @-} -{-@ Admit :: {v:QED | isAdmit v } @-} +isAdmit :: QED -> Bool +isAdmit Admit = True +isAdmit QED = False ------------------------------------------------------------------------------- diff --git a/liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/Check.hs b/liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/Check.hs index b7d766731..944e64719 100644 --- a/liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/Check.hs +++ b/liquidhaskell-boot/src/Language/Haskell/Liquid/Bare/Check.hs @@ -173,6 +173,9 @@ checkTargetSpec specs src env cbs tsp <> checkSizeFun emb env (gsTconsP (gsName tsp)) <> checkPlugged (catMaybes [ fmap (F.dropSym 2 $ GM.simplesymbol x,) (getMethodType t) | (x, t) <- gsMethods (gsSig tsp) ]) <> checkRewrites tsp + <> if allowUnsafeConstructors $ getConfig tsp + then mempty + else checkConstructorRefinement (gsTySigs $ gsSig tsp) _rClasses = concatMap Ms.classes specs _rInsts = concatMap Ms.rinstance specs @@ -193,6 +196,39 @@ checkTargetSpec specs src env cbs tsp +-- | Tests that the returned refinement type of data constructors has predicate @True@ or @prop v == e@. +-- +-- > data T = T Int +-- > {-@ T :: x:Int -> { v:T | v = T x } @-} -- Should be rejected +-- > {-@ T :: x:Int -> { v:T | True } @-} -- Should be fine +-- > {-@ T :: x:Int -> { v:T | prop v = True } @-} -- Should be fine +-- +checkConstructorRefinement :: [(Var, LocSpecType)] -> Diagnostics +checkConstructorRefinement = mconcat . map checkOne + where + checkOne (s, ty) | isCtorName s + , not $ validRef $ getRetTyRef $ val ty + = mkDiagnostics mempty [ ErrCtorRefinement (GM.sourcePosSrcSpan $ loc ty) (pprint s) ] + checkOne _ = mempty + + getRetTyRef (RFun _ _ _ t _) = getRetTyRef t + getRetTyRef (RAllT _ t _) = getRetTyRef t + getRetTyRef t = ur_reft $ rt_reft t + + -- True refinement + validRef (F.Reft (_, F.PTrue)) + = True + -- Prop foo from ProofCombinators + validRef (F.Reft (v, F.PAtom F.Eq (F.EApp (F.EVar n) (F.EVar v')) _)) + | n == "Language.Haskell.Liquid.ProofCombinators.prop" + , v == v' + = True + validRef _ = False + + isCtorName x = case idDetails x of + DataConWorkId _ -> True + DataConWrapId _ -> True + _ -> False checkPlugged :: PPrint v => [(v, LocSpecType)] -> Diagnostics diff --git a/liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Errors.hs b/liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Errors.hs index edba61632..7d74dc9b8 100644 --- a/liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Errors.hs +++ b/liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Errors.hs @@ -483,6 +483,11 @@ data TError t = , dc :: !Doc } + | ErrCtorRefinement { pos :: !SrcSpan + , ctorName :: !Doc + } -- ^ The refinement of a data constructor doesn't admit + -- a refinement on the return type that + -- isn't deemd safe | ErrOther { pos :: SrcSpan , msg :: !Doc @@ -1061,6 +1066,12 @@ ppError' _ dCtx (ErrPosTyCon _ tc dc) , nest 2 "https://ucsd-progsys.github.io/liquidhaskell/options/#positivity-check" ] +ppError' _ dCtx (ErrCtorRefinement _ ctorName) + = text "Refinement of the data constructor" <+> ctorName <+> "doesn't admit an arbitrary refinements on the return type" + $+$ dCtx + $+$ nest 4 (text "Were you trying to use `Prop` from `Language.Haskell.Liquid.ProofCombinators`?") + $+$ nest 4 (text "You can disable this error by enabling the flag `--allow-unsafe-constructors`") + ppError' _ dCtx (ErrParseAnn _ msg) = text "Malformed annotation" $+$ dCtx diff --git a/liquidhaskell-boot/src/Language/Haskell/Liquid/UX/CmdLine.hs b/liquidhaskell-boot/src/Language/Haskell/Liquid/UX/CmdLine.hs index 2abf1590e..aad60b65e 100644 --- a/liquidhaskell-boot/src/Language/Haskell/Liquid/UX/CmdLine.hs +++ b/liquidhaskell-boot/src/Language/Haskell/Liquid/UX/CmdLine.hs @@ -484,6 +484,10 @@ config = cmdArgsMode $ Config { = def &= help "Dump pre-normalized core (before a-normalization)" &= name "dump-pre-normalized-core" &= explicit + , allowUnsafeConstructors + = def &= help "Allow refining constructors with unsafe refinements" + &= name "allow-unsafe-constructors" + &= explicit } &= program "liquid" &= help "Refinement Types for Haskell" &= summary copyright @@ -748,6 +752,7 @@ defConfig = Config , excludeAutomaticAssumptionsFor = [] , dumpOpaqueReflections = False , dumpPreNormalizedCore = False + , allowUnsafeConstructors = False } -- | Write the annotations (i.e. the files in the \".liquid\" hidden folder) and diff --git a/liquidhaskell-boot/src/Language/Haskell/Liquid/UX/Config.hs b/liquidhaskell-boot/src/Language/Haskell/Liquid/UX/Config.hs index 10593091c..1aaf6fd0e 100644 --- a/liquidhaskell-boot/src/Language/Haskell/Liquid/UX/Config.hs +++ b/liquidhaskell-boot/src/Language/Haskell/Liquid/UX/Config.hs @@ -126,6 +126,7 @@ data Config = Config , excludeAutomaticAssumptionsFor :: [String] , dumpOpaqueReflections :: Bool -- Dumps all opaque reflections to the stdout , dumpPreNormalizedCore :: Bool -- Dumps the prenormalized core (before a-normalization) + , allowUnsafeConstructors :: Bool -- ^ Allow refining constructors with unsafe refinements } deriving (Generic, Data, Typeable, Show, Eq) allowPLE :: Config -> Bool diff --git a/tests/benchmarks/cse230/src/Week10/ProofCombinators.hs b/tests/benchmarks/cse230/src/Week10/ProofCombinators.hs index e458c8939..91d741bf9 100644 --- a/tests/benchmarks/cse230/src/Week10/ProofCombinators.hs +++ b/tests/benchmarks/cse230/src/Week10/ProofCombinators.hs @@ -73,7 +73,9 @@ _ *** _ = () data QED = Admit | QED {-@ measure isAdmit :: QED -> Bool @-} -{-@ Admit :: {v:QED | isAdmit v } @-} +isAdmit :: QED -> Bool +isAdmit Admit = True +isAdmit QED = False ------------------------------------------------------------------------------- diff --git a/tests/neg/RefCtor.hs b/tests/neg/RefCtor.hs new file mode 100644 index 000000000..a6a0f3194 --- /dev/null +++ b/tests/neg/RefCtor.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE GADTs #-} + +-- | Tests that the returned refinement type of data constructors +-- is not allowed to be other than @True@. +module RefCtor where + +import Language.Haskell.Liquid.ProofCombinators + +{-@ type K X Y = { _:F | X = Y } @-} + +data F where +{-@ LIQUID "--expect-error-containing=Refinement of the data constructor RefCtor.MkF doesn't admit an arbitrary refinements on the return type" @-} +{-@ MkF :: x:Int -> y:Int -> K x y @-} + MkF :: Int -> Int -> F + +{-@ falseProof :: { false } @-} +falseProof = () ? MkF 0 2 \ No newline at end of file diff --git a/tests/pos/AllowUnsafeCtor.hs b/tests/pos/AllowUnsafeCtor.hs new file mode 100644 index 000000000..55f1f12a5 --- /dev/null +++ b/tests/pos/AllowUnsafeCtor.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE GADTs #-} + +module AllowUnsafeCtor where + +import Language.Haskell.Liquid.ProofCombinators + +{-@ type K X Y = { _:F | X = Y } @-} + +{-@ LIQUID "--allow-unsafe-constructors" @-} +data F where +{-@ MkF :: x:Int -> y:Int -> K x y @-} + MkF :: Int -> Int -> F + +{-@ falseProof :: { false } @-} +falseProof = () ? MkF 0 2 \ No newline at end of file diff --git a/tests/pos/CountMonad.hs b/tests/pos/CountMonad.hs index df5468fb7..6e3d6b606 100644 --- a/tests/pos/CountMonad.hs +++ b/tests/pos/CountMonad.hs @@ -4,7 +4,6 @@ module CountMonad () where {-@ measure count :: Count a -> Int @-} -{-@ Count :: x:a -> {v:Count a | v == Count x } @-} data Count a = Count a instance Functor Count where @@ -36,7 +35,6 @@ assertCount _ x = x getCount :: Count a -> Int getCount _ = 0 -{-@ makeCount :: x:a -> {v:Count a | v == Count x} @-} makeCount = Count {-@ assume incr :: a -> {v:Count a | count v == 1 } @-} diff --git a/tests/tests.cabal b/tests/tests.cabal index c0a383853..f6b842a9f 100644 --- a/tests/tests.cabal +++ b/tests/tests.cabal @@ -1297,6 +1297,7 @@ executable unit-neg , Record0 , RecQSort , RecSelector + , RefCtor , RefinedProp , Revshape , ReWrite2