never executed always true always false

    1 {-# LANGUAGE QuasiQuotes #-}
    2 
    3 module Conjure.Representations.Set.Explicit ( setExplicit ) where
    4 
    5 -- conjure
    6 import Conjure.Prelude
    7 import Conjure.Language
    8 import Conjure.Representations.Internal
    9 
   10 
   11 setExplicit :: forall m . (MonadFailDoc m, NameGen m) => Representation m
   12 setExplicit = Representation chck downD structuralCons downC up symmetryOrdering
   13 
   14     where
   15 
   16         chck :: TypeOf_ReprCheck m
   17         chck f (DomainSet _ attrs@(SetAttr SizeAttr_Size{}) innerDomain) =
   18             map (DomainSet Set_Explicit attrs) <$> f innerDomain
   19         chck _ _ = return []
   20 
   21         outName :: Domain HasRepresentation x -> Name -> Name
   22         outName = mkOutName Nothing
   23 
   24         downD :: TypeOf_DownD m
   25         downD (name, domain@(DomainSet Set_Explicit (SetAttr (SizeAttr_Size size)) innerDomain)) = return $ Just
   26             [ ( outName domain name
   27               , DomainMatrix
   28                   (DomainInt TagInt [RangeBounded 1 size])
   29                   innerDomain
   30               ) ]
   31         downD _ = na "{downD} Explicit"
   32 
   33         structuralCons :: TypeOf_Structural m
   34         structuralCons f downX1 (DomainSet Set_Explicit (SetAttr (SizeAttr_Size size)) innerDomain) = do
   35             let
   36                 ordering m = do
   37                     (iPat, i) <- quantifiedVar
   38                     return $ return -- for list
   39                         [essence|
   40                             forAll &iPat : int(1..&size-1) .
   41                                 &m[&i] .< &m[&i+1]
   42                         |]
   43 
   44                 innerStructuralCons m = do
   45                     (iPat, i) <- quantifiedVarOverDomain [essenceDomain| int(1..&size) |]
   46                     let activeZone b = [essence| forAll &iPat : int(1..&size) . &b |]
   47 
   48                     -- preparing structural constraints for the inner guys
   49                     innerStructuralConsGen <- f innerDomain
   50 
   51                     let inLoop = [essence| &m[&i] |]
   52                     outs <- innerStructuralConsGen inLoop
   53                     return (map activeZone outs)
   54 
   55             return $ \ ref -> do
   56                 refs <- downX1 ref
   57                 case refs of
   58                     [m] ->
   59                         concat <$> sequence
   60                             [ ordering m
   61                             , innerStructuralCons m
   62                             ]
   63                     _ -> na "{structuralCons} Explicit"
   64         structuralCons _ _ _ = na "{structuralCons} Explicit"
   65 
   66         downC :: TypeOf_DownC m
   67         downC ( name
   68               , domain@(DomainSet Set_Explicit (SetAttr (SizeAttr_Size size)) innerDomain)
   69               , viewConstantSet -> Just constants
   70               ) =
   71             let outIndexDomain = mkDomainIntB 1 size
   72             in  return $ Just
   73                     [ ( outName domain name
   74                       , DomainMatrix outIndexDomain innerDomain
   75                       , ConstantAbstract $ AbsLitMatrix outIndexDomain constants
   76                       ) ]
   77         downC _ = na "{downC} Explicit"
   78 
   79         up :: TypeOf_Up m
   80         up ctxt (name, domain@(DomainSet Set_Explicit (SetAttr (SizeAttr_Size _)) _)) =
   81             case lookup (outName domain name) ctxt of
   82                 Nothing -> failDoc $ vcat $
   83                     [ "(in Set Explicit 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                 Just constant ->
   90                     case viewConstantMatrix constant of
   91                         Just (_, vals) ->
   92                             return (name, ConstantAbstract (AbsLitSet vals))
   93                         _ -> failDoc $ vcat
   94                                 [ "Expecting a matrix literal for:" <+> pretty (outName domain name)
   95                                 , "But got:" <+> pretty constant
   96                                 , "When working on:" <+> pretty name
   97                                 , "With domain:" <+> pretty domain
   98                                 ]
   99         up _ _ = na "{up} Explicit"
  100 
  101         symmetryOrdering :: TypeOf_SymmetryOrdering m
  102         symmetryOrdering innerSO downX1 inp domain = do
  103             [inner] <- downX1 inp
  104             Just [(_, innerDomain)] <- downD ("SO", domain)
  105             innerSO downX1 inner innerDomain
  106