module Coverage.Internal where
import Data.List (sortBy)
import Data.Function (on)
import Data.Maybe (fromMaybe)
import Control.Applicative (Applicative, (<*>), pure, liftA2)
import Control.Arrow (first)
type Name = String
type Binders lit = [Binder lit]
data Binder lit
= Var (Maybe Name)
| Lit lit
| Tagged Name (Binder lit)
| Product (Binders lit)
| Record [(Name, Binder lit)]
deriving (Show, Eq)
newtype Environment = Environment { envInfo :: Name -> Maybe [Name] }
makeEnv :: (Name -> Maybe [Name]) -> Environment
makeEnv info = Environment { envInfo = info }
defaultEnv :: Environment
defaultEnv = makeEnv (\_ -> Nothing)
data Guard = CatchAll | Opaque
deriving (Show, Eq)
type Alternative lit = (Binders lit, Maybe Guard)
data Redundant a = DontKnow | Redundant | NotRedundant a
deriving (Show, Eq)
instance Functor Redundant where
fmap _ DontKnow = DontKnow
fmap _ Redundant = Redundant
fmap f (NotRedundant r) = NotRedundant $ f r
instance Applicative Redundant where
pure = NotRedundant
DontKnow <*> _ = DontKnow
Redundant <*> _ = Redundant
(NotRedundant f) <*> m = fmap f m
data Check lit = Check
{ getUncovered :: [Binders lit]
, getRedundant :: Redundant [Binders lit]
} deriving (Show, Eq)
makeCheck :: [Binders lit] -> Redundant [Binders lit] -> Check lit
makeCheck bs red = Check
{ getUncovered = bs
, getRedundant = red }
applyUncovered :: ([Binders lit] -> [Binders lit]) -> Check lit -> Check lit
applyUncovered f c = makeCheck (f $ getUncovered c) (getRedundant c)
applyRedundant :: (Redundant [Binders lit] -> Redundant [Binders lit]) -> Check lit -> Check lit
applyRedundant f c = makeCheck (getUncovered c) (f $ getRedundant c)
wildcard :: Binder lit
wildcard = Var Nothing
genericMerge :: Ord a =>
(a -> Maybe b -> Maybe c -> d) ->
[(a, b)] ->
[(a, c)] ->
[d]
genericMerge _ [] [] = []
genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs
genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs
genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')
| s < s' = (f s (Just b) Nothing) : genericMerge f bs bsr
| s > s' = (f s' Nothing (Just b')) : genericMerge f bsl bs'
| otherwise = (f s (Just b) (Just b')) : genericMerge f bs bs'
missingSingle :: (Eq lit) => Environment -> Binder lit -> Binder lit -> ([Binder lit], Maybe Bool)
missingSingle _ _ (Var _) = ([], pure True)
missingSingle env (Var _) (Product ps) =
first (map Product) $ missingMultiple env (initialize $ length ps) ps
missingSingle env p@(Product ps) (Product ps')
| length ps == length ps' = first (map Product) $ missingMultiple env ps ps'
| otherwise = ([p], pure False)
missingSingle env (Var _) cb@(Tagged con _) =
(concatMap (\cp -> fst $ missingSingle env cp cb) $ tagEnv, pure True)
where
tag :: (Eq lit) => Name -> Binder lit
tag n = Tagged n wildcard
tagEnv :: (Eq lit) => [Binder lit]
tagEnv = map tag
. fromMaybe (error $ "Constructor name '" ++ con ++ "' not in the scope of the current environment in missingSingle.")
. envInfo env $ con
missingSingle env c@(Tagged tag bs) (Tagged tag' bs')
| tag == tag' = let (bs'', pr) = missingSingle env bs bs' in (map (Tagged tag) bs'', pr)
| otherwise = ([c], pure False)
missingSingle env (Var _) (Record bs) =
(map (Record . zip names) $ miss, pr)
where
(miss, pr) = missingMultiple env (initialize $ length bs) binders
(names, binders) = unzip bs
missingSingle env (Record bs) (Record bs') =
(map (Record . zip sortedNames) $ allMisses, pr)
where
(allMisses, pr) = uncurry (missingMultiple env) $ unzip binders
sortNames = sortBy (compare `on` fst)
(sbs, sbs') = (sortNames bs, sortNames bs')
compB :: a -> Maybe a -> Maybe a -> (a, a)
compB e b b' = (fm b, fm b')
where
fm = fromMaybe e
compBS :: Eq a => b -> a -> Maybe b -> Maybe b -> (a, (b, b))
compBS e s b b' = (s, compB e b b')
(sortedNames, binders) = unzip $ genericMerge (compBS (Var Nothing)) sbs sbs'
missingSingle _ b@(Lit l) (Lit l')
| l == l' = ([], pure True)
| otherwise = ([b], pure False)
missingSingle _ b _ = ([b], Nothing)
initialize :: Int -> [Binder lit]
initialize = flip replicate $ wildcard
missingMultiple :: (Eq lit) => Environment -> Binders lit -> Binders lit -> ([Binders lit], Maybe Bool)
missingMultiple env = go
where
go [] [] = ([], pure True)
go (x:xs) (y:ys) = (map (: xs) missed ++ fmap (x :) missed', liftA2 (&&) pr1 pr2)
where
(missed, pr1) = missingSingle env x y
(missed', pr2) = go xs ys
go _ _ = error "Error in missingMultiple: invalid length of argument binders."
missingCases :: (Eq lit) => Environment -> Binders lit -> Alternative lit -> ([Binders lit], Maybe Bool)
missingCases env unc = missingMultiple env unc . fst
missingAlternative :: (Eq lit) => Environment -> Alternative lit -> Binders lit -> ([Binders lit], Maybe Bool)
missingAlternative env alt unc
| isExhaustiveGuard $ snd alt = mcases
| otherwise = ([unc], snd mcases)
where
mcases = missingCases env unc alt
isExhaustiveGuard :: Maybe Guard -> Bool
isExhaustiveGuard (Just Opaque) = False
isExhaustiveGuard _ = True