Coveralls and stack support (#44)

* Implement coveralls support

Author: MaximilianAlgehed

.github/workflows/haskell-ci.yml

@@ -1,4 +1,6 @@
 name: Haskell-CI
+permissions:
+  contents: read
 
 on:
   push:
@@ -15,13 +17,13 @@ concurrency:
   cancel-in-progress: true
 
 jobs:
-  linux:
+  test-with-cabal:
     name: Haskell-CI - Linux - ${{ matrix.ghc-version }}
 
     strategy:
       matrix:
         ghc-version: [latest, 9.12, "9.10", 9.8, 9.6]
-        os: [ubuntu-24.04]
+        os: [ubuntu-latest]
       fail-fast: false
 
     runs-on: ${{ matrix.os }}
@@ -43,3 +45,45 @@ jobs:
         with:
           key: ${{ matrix.os }}-${{ matrix.ghc-version }}-${{ github.sha }}
           path: ~/.cabal/store
+
+  test-with-stack:
+    name: Stack
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v4
+
+    - uses: haskell-actions/setup@v2
+      id: setup-haskell-stack
+      name: Setup Haskell
+      with:
+        enable-stack: true
+        stack-version: latest
+        ghc-version: 9.6.7
+
+    - name: Cache
+      id: cache
+      uses: actions/cache@v4
+      with:
+        path: |
+          ${{ steps.setup-haskell-stack.outputs.stack-root }}
+          .stack-work
+        key: ${{ runner.os }}-stack-${{ github.sha }}
+        restore-keys: ${{ runner.os }}-stack
+
+    - name: Test
+      run: stack test --coverage --flag constrained-generators:dev
+
+    - uses: actions/cache/save@v4
+      with:
+        path: |
+          ${{ steps.setup-haskell-stack.outputs.stack-root }}
+          .stack-work
+        key: ${{ runner.os }}-stack-${{ github.sha }}
+
+    - name: Upload coverage report
+      env:
+        COVERALLS_REPO_TOKEN: ${{ secrets.COVERALLS_REPO_TOKEN }}
+      run: |
+        [ -n "${COVERALLS_REPO_TOKEN}" ]
+        curl -L https://github.com/rubik/stack-hpc-coveralls/releases/download/v0.0.7.0/shc-Linux-X64.tar.bz2 | tar xj shc
+        ./shc --repo-token="$COVERALLS_REPO_TOKEN" --partial-coverage --fetch-coverage combined all

constrained-generators.cabal

@@ -121,7 +121,7 @@ library examples
     prettyprinter,
     random,
 
-test-suite constrained
+test-suite constrained-tests
   type: exitcode-stdio-1.0
   main-is: Tests.hs
   hs-source-dirs: test
@@ -141,9 +141,12 @@ test-suite constrained
     QuickCheck,
     base,
     constrained-generators,
-    constrained-generators:examples,
     containers,
-    hspec,
+    hspec
+
+  if !flag(dev)
+    build-depends:
+      constrained-generators:examples
 
 benchmark bench
   type: exitcode-stdio-1.0

examples/Constrained/Examples/Basic.hs

@@ -363,3 +363,6 @@ pairCant = constrained' $ \ [var| i |] [var| p |] ->
     , not_ $ k `elem_` lit [1..9]
     ]
   ]
+
+signumPositive :: Specification Rational
+signumPositive = constrained $ \ x -> signum (x * 30) >=. 1

examples/Constrained/Examples/CheatSheet.hs

@@ -364,7 +364,7 @@ tightFit0 = constrained' $ \x y ->
 --         TypeSpec (Cartesian TrueSpec (MemberSpec [0])) []
 --         ---
 --         assert $ Equal (Fst (ToGeneric v_3)) v_1
---   Env {unEnv = fromList [(v_0,EnvValue 0)]}
+--   Env (fromList [(v_0,EnvValue 0)])
 -- genFromSpecT ErrorSpec{} with explanation:
 -- [1..-1]
 

src/Constrained/Base.hs

@@ -101,10 +101,6 @@ import Constrained.GenT
 import Constrained.Generic
 import Constrained.List hiding (toList)
 import Constrained.TypeErrors
-import Control.Monad.Writer (
-  Writer,
-  tell,
- )
 import Data.Foldable (
   toList,
  )
@@ -524,12 +520,6 @@ class
   alternateShow :: TypeSpec a -> BinaryShow
   alternateShow _ = NonBinary
 
-  monadConformsTo :: a -> TypeSpec a -> Writer [String] Bool
-  monadConformsTo x spec =
-    if conformsTo @a x spec
-      then pure True
-      else tell ["Fails by " ++ show spec] >> pure False
-
   -- | For some types (especially finite ones) there may be much better ways to construct
   --   a Specification than the default method of just adding a large 'bad' list to TypSpec. This
   --   function allows each HasSpec instance to decide.

src/Constrained/Conformance.hs

@@ -14,7 +14,6 @@ module Constrained.Conformance (
   conformsToSpec,
   conformsToSpecE,
   satisfies,
-  checkPred,
   checkPredsE,
 ) where
 
@@ -34,59 +33,9 @@ import Data.Semigroup (sconcat)
 import Prettyprinter hiding (cat)
 import Test.QuickCheck (Property, Testable, property)
 
--- =========================================================================
-
--- | Does the Pred evaluate to true under the given Env.
---   If it doesn't, some explanation appears in the failure of the monad 'm'
-checkPred :: forall m. MonadGenError m => Env -> Pred -> m Bool
-checkPred env = \case
-  p@(ElemPred bool term xs) -> do
-    v <- runTerm env term
-    case (elem v xs, bool) of
-      (True, True) -> pure True
-      (True, False) -> fatalErrorNE ("notElemPred reduces to True" :| [show p])
-      (False, True) -> fatalErrorNE ("elemPred reduces to False" :| [show p])
-      (False, False) -> pure True
-  Monitor {} -> pure True
-  Subst x t p -> checkPred env $ substitutePred x t p
-  Assert t -> runTerm env t
-  GenHint {} -> pure True
-  p@(Reifies t' t f) -> do
-    val <- runTerm env t
-    val' <- runTerm env t'
-    explainNE (NE.fromList ["Reification:", "  " ++ show p]) $ pure (f val == val')
-  ForAll t (x :-> p) -> do
-    set <- runTerm env t
-    and
-      <$> sequence
-        [ checkPred env' p
-        | v <- forAllToList set
-        , let env' = Env.extend x v env
-        ]
-  Case t bs -> do
-    v <- runTerm env t
-    runCaseOn v (mapList thing bs) (\x val ps -> checkPred (Env.extend x val env) ps)
-  When bt p -> do
-    b <- runTerm env bt
-    if b then checkPred env p else pure True
-  TruePred -> pure True
-  FalsePred es -> explainNE es $ pure False
-  DependsOn {} -> pure True
-  And ps -> checkPreds env ps
-  Let t (x :-> p) -> do
-    val <- runTerm env t
-    checkPred (Env.extend x val env) p
-  Exists k (x :-> p) -> do
-    a <- runGE $ k (errorGE . explain "checkPred: Exists" . runTerm env)
-    checkPred (Env.extend x a env) p
-  Explain es p -> explainNE es $ checkPred env p
-
-checkPreds :: (MonadGenError m, Traversable t) => Env -> t Pred -> m Bool
-checkPreds env ps = and <$> mapM (checkPred env) ps
-
 -- ==========================================================
 
--- | Like checkPred, But it takes [Pred] rather than a single Pred,
+-- | Like checkPredE, But it takes [Pred] rather than a single Pred,
 --   and it builds a much more involved explanation if it fails.
 --   Does the Pred evaluate to True under the given Env?
 --   If it doesn't, an involved explanation appears in the (Just message)
@@ -101,8 +50,9 @@ checkPredsE msgs env ps =
     [] -> Nothing
     (x : xs) -> Just (NE.nub (sconcat (x NE.:| xs)))
 
--- | An involved explanation for a single Pred
---   The most important explanations come when an assertion fails.
+-- | Does the Pred evaluate to true under the given Env. An involved
+-- explanation for a single Pred in case of failure and `Nothing` otherwise.
+-- The most important explanations come when an assertion fails.
 checkPredE :: Env -> NE.NonEmpty String -> Pred -> Maybe (NE.NonEmpty String)
 checkPredE env msgs = \case
   p@(ElemPred bool t xs) ->

src/Constrained/Env.hs

@@ -27,7 +27,7 @@ import Prettyprinter
 import Prelude hiding (lookup)
 
 -- | Typed environments for mapping @t`Var` a@ to @a@
-newtype Env = Env {unEnv :: Map EnvKey EnvValue}
+newtype Env = Env (Map EnvKey EnvValue)
   deriving newtype (Semigroup, Monoid)
   deriving stock (Show)
 

src/Constrained/NumOrd.hs

@@ -774,6 +774,33 @@ instance {-# OVERLAPPABLE #-} (HasSpec a, MaybeBounded a, Integral a, TypeSpec a
           then r - signum a
           else r
 
+instance HasDivision (Ratio Integer) where
+  doDivide = (/)
+
+  divideSpec 0 _ = TrueSpec
+  divideSpec a (NumSpecInterval ml mu) = typeSpec ts
+    where
+      ts | a > 0 = NumSpecInterval ml' mu'
+         | otherwise = NumSpecInterval mu' ml'
+      ml' = adjustLowerBound <$> ml
+      mu' = adjustUpperBound <$> mu
+      adjustLowerBound l =
+        let r = l / a
+            l' = r * a
+        in
+        if l' < l
+        then r + (l - l') * 2 / a
+        else r
+
+      adjustUpperBound u =
+        let r = u / a
+            u' = r * a
+        in
+        if u < u'
+        then r - (u' - u) * 2 / a
+        else r
+
+
 instance HasDivision Float where
   doDivide = (/)
 

src/Constrained/Syntax.hs

@@ -51,7 +51,6 @@ module Constrained.Syntax (
   computeDependencies,
   solvableFrom,
   respecting,
-  dependency,
   applyNameHints,
   envFromPred,
   isLit,
@@ -834,10 +833,6 @@ applyNameHints spec = spec
 -- | `Graph` specialized to dependencies for variables
 type DependGraph = Graph.Graph Name
 
--- | A variable depends on a thing witha buch of other variables
-dependency :: HasVariables t => Name -> t -> DependGraph
-dependency x (freeVarSet -> xs) = Graph.dependency x xs
-
 -- | Everything to the left depends on everything from the right, except themselves
 irreflexiveDependencyOn ::
   forall t t'. (HasVariables t, HasVariables t') => t -> t' -> DependGraph

stack.yaml

@@ -0,0 +1,4 @@
+snapshot: lts-22.44
+packages:
+- .
+system-ghc: true