never executed always true always false

    1 {-# LANGUAGE QuasiQuotes #-}
    2 
    3 module Conjure.Representations.MSet.Occurrence ( msetOccurrence ) where
    4 
    5 -- conjure
    6 import Conjure.Prelude
    7 import Conjure.Language
    8 import Conjure.Representations.Internal
    9 import Conjure.Representations.Common
   10 
   11 
   12 msetOccurrence :: forall m . (MonadFailDoc m, NameGen m) => Representation m
   13 msetOccurrence = Representation chck downD structuralCons downC up symmetryOrdering
   14 
   15     where
   16 
   17         chck :: TypeOf_ReprCheck m
   18         chck f (DomainMSet _ attrs innerDomain@DomainInt{}) = map (DomainMSet MSet_Occurrence attrs) <$> f innerDomain
   19         chck _ _ = return []
   20 
   21         outName :: Domain HasRepresentation x -> Name -> Name
   22         outName = mkOutName Nothing
   23 
   24         getMinOccur attrs = case attrs of
   25             MSetAttr _ (OccurAttr_MinOccur x) -> x
   26             MSetAttr _ (OccurAttr_MinMaxOccur x _) -> x
   27             MSetAttr _ _ -> 0
   28 
   29         getMaxOccur attrs = case attrs of
   30             MSetAttr _ (OccurAttr_MaxOccur x) -> return x
   31             MSetAttr _ (OccurAttr_MinMaxOccur _ x) -> return x
   32             MSetAttr (SizeAttr_Size x) _ -> return x
   33             MSetAttr (SizeAttr_MaxSize x) _ -> return x
   34             MSetAttr (SizeAttr_MinMaxSize _ x) _ -> return x
   35             _ -> failDoc ("getMaxOccur, mset not supported. attributes:" <+> pretty attrs)
   36 
   37         downD :: TypeOf_DownD m
   38         downD (name, domain@(DomainMSet MSet_Occurrence attrs innerDomain@DomainInt{})) = do
   39             maxOccur <- getMaxOccur attrs
   40             return $ Just
   41                 [ ( outName domain name
   42                   , DomainMatrix (forgetRepr innerDomain) (DomainInt TagInt [RangeBounded 0 maxOccur])
   43                   )
   44                 ]
   45         downD _ = na "{downD} Occurrence"
   46 
   47         structuralCons :: TypeOf_Structural m
   48         structuralCons _ downX1 (DomainMSet MSet_Occurrence
   49                                     attrs@(MSetAttr sizeAttr _occurAttr)
   50                                     innerDomain@DomainInt{}) =
   51             return $ \ mset -> do
   52                 refs <- downX1 mset
   53                 case refs of
   54                     [m] -> do
   55                         (iPat, i) <- quantifiedVar
   56                         let
   57                             minOccur = getMinOccur attrs
   58                             minOccurCons =
   59                                 [ [essence| forAll &iPat : &innerDomain . &m[&i] >= &minOccur |]
   60                                 | minOccur /= 0 ]
   61                         let
   62                             cardinality = [essence| sum &iPat : &innerDomain . &m[&i] |]
   63                             cardinalityCons = mkSizeCons sizeAttr cardinality
   64                         return (minOccurCons ++ cardinalityCons)
   65                     _ -> na "{structuralCons} Occurrence"
   66         structuralCons _ _ _ = na "{structuralCons} Occurrence"
   67 
   68         downC :: TypeOf_DownC m
   69         downC ( name
   70               , domain@(DomainMSet MSet_Occurrence _attrs innerDomain@(DomainInt t intRanges))
   71               , viewConstantMSet -> Just constants
   72               ) = do
   73                 innerDomainVals <- valuesInIntDomain intRanges
   74                 return $ Just
   75                     [ ( outName domain name
   76                       , DomainMatrix (forgetRepr innerDomain) DomainBool
   77                       , ConstantAbstract $ AbsLitMatrix (forgetRepr innerDomain)
   78                           [ ConstantBool isIn
   79                           | v <- innerDomainVals
   80                           , let isIn = ConstantInt t v `elem` constants
   81                           ]
   82                       )
   83                     ]
   84         downC _ = na "{downC} Occurrence"
   85 
   86         up :: TypeOf_Up m
   87         up ctxt (name, domain@(DomainMSet _ _ (DomainInt t intRanges)))=
   88             case lookup (outName domain name) ctxt of
   89                 Just constantMatrix ->
   90                     case viewConstantMatrix constantMatrix of
   91                         Just (_, vals) -> do
   92                             innerDomainVals <- valuesInIntDomain intRanges
   93                             return (name, ConstantAbstract $ AbsLitMSet $ concat
   94                                             [ case viewConstantInt x of
   95                                                 Just n -> replicate (fromInteger n) (ConstantInt t v)
   96                                                 Nothing -> []
   97                                             | (v,x) <- zip innerDomainVals vals
   98                                             ] )
   99                         _ -> failDoc $ vcat
  100                                 [ "Expecting a matrix literal for:" <+> pretty (outName domain name)
  101                                 , "But got:" <+> pretty constantMatrix
  102                                 , "When working on:" <+> pretty name
  103                                 , "With domain:" <+> pretty domain
  104                                 ]
  105                 Nothing -> failDoc $ vcat $
  106                     [ "(in MSet Occurrence up)"
  107                     , "No value for:" <+> pretty (outName domain name)
  108                     , "When working on:" <+> pretty name
  109                     , "With domain:" <+> pretty domain
  110                     ] ++
  111                     ("Bindings in context:" : prettyContext ctxt)
  112         up _ _ = na "{up} Occurrence"
  113 
  114         symmetryOrdering :: TypeOf_SymmetryOrdering m
  115         symmetryOrdering innerSO downX1 inp domain = do 
  116             [inner] <- downX1 inp
  117             Just [(_, innerDomain)] <- downD ("SO", domain)
  118             innerSO downX1 inner innerDomain
  119