Verified Commit de1bb270 authored by Sven Keidel's avatar Sven Keidel
Browse files

add some CoComplete instances

parent 7a220e49
Pipeline #69666 failed with stages
in 47 minutes and 43 seconds
......@@ -41,6 +41,11 @@ union Top _ = Top
union _ Top = Top
union (Pow xs) (Pow ys) = Pow (H.union xs ys)
intersection :: Identifiable x => Pow x -> Pow x -> Pow x
intersection Top ys = ys
intersection xs Top = xs
intersection (Pow xs) (Pow ys) = Pow (H.intersection xs ys)
unions :: Identifiable x => Pow (Pow x) -> Pow x
unions (Pow xs) = foldr union empty xs
unions Top = Top
......@@ -75,9 +80,18 @@ instance Identifiable x => PreOrd (Pow x) where
_ Top = True
_ _ = False
instance Identifiable x => UpperBounded (Pow x) where
top = Top
instance Identifiable x => Complete (Pow x) where
() = union
instance Identifiable x => CoComplete (Pow x) where
() = intersection
instance Identifiable x => LowerBounded (Pow x) where
bottom = Pow H.empty
instance Identifiable x => Semigroup (Pow x) where
(<>) = union
......@@ -102,12 +116,6 @@ instance Identifiable x => Complete (FreeCompletion (Pow x)) where
instance Hashable x => Hashable (Pow x)
instance Identifiable x => UpperBounded (Pow x) where
top = Top
instance Identifiable x => LowerBounded (Pow x) where
bottom = Pow H.empty
instance Identifiable x => IsList (Pow x) where
type Item (Pow x) = x
fromList ls = Pow (H.fromList ls)
......
......@@ -14,6 +14,7 @@ import Control.Monad
import Control.Monad.Except
import Control.DeepSeq
import Data.String
import Data.Profunctor
import Data.Bifunctor hiding (second)
import Data.Hashable
......@@ -56,6 +57,9 @@ instance MonadError e (Error e) where
catchError (Fail e) f = f e
catchError (Success a) _ = Success a
instance IsString e => MonadFail (Error e) where
fail e = Fail (fromString e)
instance Applicative (Error e) where
pure = return
(<*>) = ap
......@@ -90,15 +94,24 @@ instance (PreOrd e, PreOrd a) => PreOrd (Error e a) where
instance (Complete e,Complete a) => Complete (Error e a) where
() = toJoin2 widening () ()
instance (PreOrd a, UpperBounded e) => UpperBounded (Error e a) where
top = Fail top
widening :: Widening e -> Widening a -> Widening (Error e a)
widening we _ (Fail a) (Fail b) = second Fail (a `we` b)
widening _ wa (Success a) (Success b) = second Success (a `wa` b)
widening _ _ (Fail a) (Success _) = (Unstable ,Fail a)
widening _ _ (Success _) (Fail b) = (Unstable ,Fail b)
instance (CoComplete e,CoComplete a) => CoComplete (Error e a) where
Fail x Fail y = Fail (x y)
Fail _ Success y = Success y
Success x Fail _ = Success x
Success x Success y = Success (x y)
instance (PreOrd a, UpperBounded e) => UpperBounded (Error e a) where
top = Fail top
instance (PreOrd e, LowerBounded a) => LowerBounded (Error e a) where
bottom = Success bottom
instance (PreOrd e, PreOrd a, Complete (FreeCompletion e), Complete (FreeCompletion a)) => Complete (FreeCompletion (Error e a)) where
Lower m1 Lower m2 = case (bimap Lower Lower m1 bimap Lower Lower m2) of
Fail (Lower e) -> Lower (Fail e)
......
......@@ -6,6 +6,7 @@ module Data.Concrete.Error where
import Data.Hashable
import Data.Profunctor
import Data.String
import Control.Monad
import Control.Arrow hiding (ArrowMonad)
......@@ -23,6 +24,9 @@ instance Monad (Error e) where
Fail e >>= _ = Fail e
Success a >>= k = k a
instance IsString e => MonadFail (Error e) where
fail e = Fail (fromString e)
instance (ArrowChoice c, Profunctor c) => ArrowFunctor (Error e) c where
mapA f = lmap toEither (arr Fail ||| rmap Success f)
{-# INLINE mapA #-}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment