never executed always true always false

    1 {-# LANGUAGE QuasiQuotes #-}
    2 
    3 module Conjure.Representations.Variant
    4     ( variant
    5     ) where
    6 
    7 -- conjure
    8 import Conjure.Prelude
    9 import Conjure.Bug
   10 import Conjure.Language
   11 import Conjure.Representations.Internal
   12 import Conjure.Language.ZeroVal ( EnumerateDomain, zeroVal )
   13 
   14 
   15 variant :: forall m . (MonadFailDoc m, NameGen m, EnumerateDomain m) => Representation m
   16 variant = Representation chck downD structuralCons downC up symmetryOrdering
   17 
   18     where
   19 
   20         chck :: TypeOf_ReprCheck m
   21         chck f (DomainVariant ds) = do
   22             let names = map fst ds
   23             outDoms <- sequence <$> mapM (f . snd) ds
   24             return [ DomainVariant (zip names ds') | ds' <- outDoms ]
   25         chck _ _ = return []
   26 
   27         mkName name n = mconcat [name, "_", n]
   28 
   29         downD :: TypeOf_DownD m
   30         downD (name, DomainVariant ds) = return $ Just
   31             $ (mkName name "_tag", defRepr $ mkDomainIntB 1 (fromInt (genericLength ds)))
   32             : [ (mkName name n, d)
   33               | (n,d) <- ds
   34               ]
   35         downD _ = na "{downD}"
   36 
   37         structuralCons :: TypeOf_Structural m
   38         structuralCons f downX1 (DomainVariant ds) = do
   39             let
   40                 innerStructuralCons which thisIndex thisRef thisDom = do
   41                     let activeZone b = [essence| &which = &thisIndex -> &b |]
   42                     -- preparing structural constraints for the inner guys
   43                     innerStructuralConsGen <- f thisDom
   44                     outs <- innerStructuralConsGen thisRef
   45                     return (map activeZone outs)
   46 
   47                 dontCares which thisIndex thisRef =
   48                     [essence| &which != &thisIndex -> dontCare(&thisRef) |]
   49 
   50             return $ \ rec -> do
   51                 (which:refs) <- downX1 rec
   52                 concat <$> sequence
   53                     [ do
   54                         isc <- innerStructuralCons which (fromInt i) ref dom
   55                         let dcs = dontCares        which (fromInt i) ref
   56                         return (dcs:isc)
   57                     | (i, ref, (_, dom)) <- zip3 [1..] refs ds
   58                     ]
   59         structuralCons _ _ _ = na "{structuralCons} variant"
   60 
   61         -- TODO: check if (length ds == length cs)
   62         downC :: TypeOf_DownC m
   63         downC (name, DomainVariant ds, ConstantAbstract (AbsLitVariant _ n c)) = do
   64             let theTag =
   65                     ( mkName name "_tag"
   66                     , defRepr $ mkDomainIntB 1 (fromInt (genericLength ds))
   67                     , case [ fromInt i
   68                            | (i, (n', _)) <- zip [1..] ds
   69                            , n == n' ] of
   70                           [v] -> v
   71                           _   -> bug "downC variant tag"
   72                     )
   73             outs <- forM ds $ \ (n', d) -> do
   74                         c' <- if n == n'
   75                                 then return c
   76                                 else zeroVal d
   77                         return (mkName name n', d, c')
   78             return $ Just (theTag : outs)
   79         downC (n, d, c) =
   80             na $ "{downC} variant" <+> vcat
   81                 [ "name  :" <+> pretty n
   82                 , "domain:" <+> pretty d
   83                 , "value :" <+> pretty c
   84                 ]
   85 
   86         up :: TypeOf_Up m
   87         up ctxt (name, DomainVariant ds) = do
   88             let dsForgotten = [ (n, defRepr d) | (n,d) <- ds ]
   89             case lookup (mkName name "_tag") ctxt of
   90                 Just (ConstantInt _ i) ->
   91                     let iTag = at ds (fromInteger (i-1)) |> fst
   92                         iName = mkName name iTag
   93                     in  case lookup iName ctxt of
   94                             Just val -> return (name, ConstantAbstract $ AbsLitVariant (Just dsForgotten) iTag val)
   95                             Nothing -> failDoc $ vcat $
   96                                 [ "(in Variant up 1)"
   97                                 , "No value for:" <+> pretty iName
   98                                 , "When working on:" <+> pretty name
   99                                 , "With domain:" <+> pretty (DomainRecord ds)
  100                                 ] ++
  101                                 ("Bindings in context:" : prettyContext ctxt)
  102                 Nothing -> failDoc $ vcat $
  103                     [ "(in Variant up 2)"
  104                     , "No value for:" <+> pretty (mkName name "_tag")
  105                     , "When working on:" <+> pretty name
  106                     , "With domain:" <+> pretty (DomainRecord ds)
  107                     ] ++
  108                     ("Bindings in context:" : prettyContext ctxt)
  109                 Just val -> failDoc $ vcat $
  110                     [ "Expecting an integer value for:" <+> pretty (mkName name "_tag")
  111                     , "When working on:" <+> pretty name
  112                     , "With domain:" <+> pretty (DomainRecord ds)
  113                     , "But got:" <+> pretty val
  114                     ] ++
  115                     ("Bindings in context:" : prettyContext ctxt)
  116         up _ _ = na "{up}"
  117 
  118         symmetryOrdering :: TypeOf_SymmetryOrdering m
  119         symmetryOrdering innerSO downX1 inp domain = do
  120             xs <- downX1 inp
  121             Just xsDoms' <- downD ("SO", domain)
  122             let xsDoms = map snd xsDoms'
  123             soValues <- sequence [ innerSO downX1 x xDom | (x, xDom) <- zip xs xsDoms ]
  124             return (fromList soValues)
  125