never executed always true always false

    1 {-# LANGUAGE QuasiQuotes #-}
    2 
    3 module Conjure.Representations.Set.Occurrence ( setOccurrence ) where
    4 
    5 -- conjure
    6 import Conjure.Prelude hiding (MonadFail,fail)
    7 import Conjure.Language
    8 import Conjure.Representations.Internal
    9 import Conjure.Representations.Common
   10 
   11 import Control.Monad.Fail
   12 
   13 
   14 setOccurrence :: forall m . (MonadFailDoc m, NameGen m) => Representation m
   15 setOccurrence = Representation chck downD structuralCons downC up symmetryOrdering
   16 
   17     where
   18 
   19         chck :: TypeOf_ReprCheck m
   20         chck f (DomainSet _ attrs innerDomain@DomainInt{}) = map (DomainSet Set_Occurrence attrs) <$> f innerDomain
   21         chck _ _ = return []
   22 
   23         outName :: Domain HasRepresentation x -> Name -> Name
   24         outName = mkOutName Nothing
   25 
   26         downD :: TypeOf_DownD m
   27         downD (name, domain@(DomainSet Set_Occurrence _attrs innerDomain@DomainInt{})) = return $ Just
   28             [ ( outName domain name
   29               , DomainMatrix (forgetRepr innerDomain) DomainBool
   30               )
   31             ]
   32         downD _ = na "{downD} Occurrence"
   33 
   34         structuralCons :: TypeOf_Structural m
   35         structuralCons _ downX1 (DomainSet Set_Occurrence (SetAttr attrs) innerDomain@DomainInt{}) =
   36             return $ \ set -> do
   37                 refs <- downX1 set
   38                 case refs of
   39                     [m] -> do
   40                         (iPat, i) <- quantifiedVar
   41                         let cardinality = [essence| sum &iPat : &innerDomain . toInt(&m[&i]) |]
   42                         return (mkSizeCons attrs cardinality)
   43                     _ -> na "{structuralCons} Occurrence"
   44         structuralCons _ _ _ = na "{structuralCons} Occurrence"
   45 
   46         downC :: TypeOf_DownC m
   47         downC ( name
   48               , domain@(DomainSet Set_Occurrence _attrs innerDomain@(DomainInt t intRanges))
   49               , viewConstantSet -> Just constants
   50               ) = do
   51                 innerDomainVals <- valuesInIntDomain intRanges
   52                 return $ Just
   53                     [ ( outName domain name
   54                       , DomainMatrix (forgetRepr innerDomain) DomainBool
   55                       , ConstantAbstract $ AbsLitMatrix (forgetRepr innerDomain)
   56                           [ ConstantBool isIn
   57                           | v <- innerDomainVals
   58                           , let isIn = ConstantInt t v `elem` constants
   59                           ]
   60                       )
   61                     ]
   62         downC _ = na "{downC} Occurrence"
   63 
   64         up :: TypeOf_Up m
   65         up ctxt (name, domain@(DomainSet _ _ (DomainInt t intRanges)))=
   66             case lookup (outName domain name) ctxt of
   67                 Just constantMatrix ->
   68                     case viewConstantMatrix constantMatrix of
   69                         Just (_, vals) -> do
   70                             innerDomainVals <- valuesInIntDomain intRanges
   71                             return (name, ConstantAbstract $ AbsLitSet
   72                                             [ ConstantInt t v
   73                                             | (v,b) <- zip innerDomainVals vals
   74                                             , viewConstantBool b == Just True
   75                                             ] )
   76                         _ -> failDoc $ vcat
   77                                 [ "Expecting a matrix literal for:" <+> pretty (outName domain name)
   78                                 , "But got:" <+> pretty constantMatrix
   79                                 , "When working on:" <+> pretty name
   80                                 , "With domain:" <+> pretty domain
   81                                 ]
   82                 Nothing -> failDoc $ vcat $
   83                     [ "(in Set Occurrence up)"
   84                     , "No value for:" <+> pretty (outName domain name)
   85                     , "When working on:" <+> pretty name
   86                     , "With domain:" <+> pretty domain
   87                     ] ++
   88                     ("Bindings in context:" : prettyContext ctxt)
   89         up _ _ = na "{up} Occurrence"
   90 
   91         -- produce a [int]
   92         symmetryOrdering :: (MonadFail m) => TypeOf_SymmetryOrdering m
   93         symmetryOrdering _innerSO downX1 inp (DomainSet Set_Occurrence _attrs innerDomain) = do
   94             [m] <- downX1 inp
   95             (iPat, i) <- quantifiedVar
   96             return [essence| [ -toInt(&m[&i]) | &iPat : &innerDomain ] |]
   97         symmetryOrdering _ _ _ _ = na "{symmetryOrdering} Occurrence"