never executed always true always false

    1 {-# LANGUAGE QuasiQuotes #-}
    2 {-# LANGUAGE ParallelListComp #-}
    3 
    4 module Conjure.Representations.Tuple
    5     ( tuple
    6     ) where
    7 
    8 -- conjure
    9 import Conjure.Prelude
   10 import Conjure.Language
   11 import Conjure.Representations.Internal
   12 
   13 -- text
   14 import Data.Text ( pack )
   15 
   16 
   17 tuple :: forall m . (MonadFailDoc m, NameGen m) => Representation m
   18 tuple = Representation chck downD structuralCons downC up symmetryOrdering
   19 
   20     where
   21 
   22         chck :: TypeOf_ReprCheck m
   23         chck f (DomainTuple ds) = map DomainTuple . sequence <$> mapM f ds
   24         chck _ _ = return []
   25 
   26         mkName :: Name -> Int -> Name
   27         mkName name i = mconcat [name, "_", Name (pack (show i))]
   28 
   29         downD :: TypeOf_DownD m
   30         downD (name, DomainTuple ds) = return $ Just
   31             [ (mkName name i, d)
   32             | i <- [1..]
   33             | d <- ds
   34             ]
   35         downD _ = na "{downD}"
   36 
   37         structuralCons :: TypeOf_Structural m
   38         structuralCons f downX1 (DomainTuple ds) = return $ \ tup -> do
   39             refs <- downX1 tup
   40             concat <$> sequence
   41                 [ do
   42                     innerStructuralConsGen <- f dom
   43                     outs                   <- innerStructuralConsGen ref
   44                     return outs
   45                 | (ref, dom) <- zip refs ds
   46                 ]
   47         structuralCons _ _ _ = na "{structuralCons} tuple"
   48 
   49         downC :: TypeOf_DownC m
   50         downC (name, DomainTuple ds, viewConstantTuple -> Just cs)
   51             | length ds == length cs = return $ Just
   52                 [ (mkName name i, d, c)
   53                 | i <- [1..]
   54                 | d <- ds
   55                 | c <- cs
   56                 ]
   57         downC (n, d, c) =
   58             na $ "{downC} tuple" <+> vcat
   59                 [ "name  :" <+> pretty n
   60                 , "domain:" <+> pretty d
   61                 , "value :" <+> pretty c
   62                 ]
   63 
   64         up :: TypeOf_Up m
   65         up ctxt (name, DomainTuple ds) = do
   66             let names = map (mkName name) [1 .. length ds]
   67             vals <- forM names $ \ n ->
   68                 case lookup n ctxt of
   69                     Nothing -> failDoc $ vcat $
   70                         [ "(in Tuple up)"
   71                         , "No value for:" <+> pretty n
   72                         , "When working on:" <+> pretty name
   73                         , "With domain:" <+> pretty (DomainTuple ds)
   74                         ] ++
   75                         ("Bindings in context:" : prettyContext ctxt)
   76                     Just val -> return val
   77             return (name, ConstantAbstract (AbsLitTuple vals))
   78         up _ _ = na "{up}"
   79 
   80         symmetryOrdering :: TypeOf_SymmetryOrdering m
   81         symmetryOrdering innerSO downX1 inp domain = do
   82             xs <- downX1 inp
   83             Just xsDoms' <- downD ("SO", domain)
   84             let xsDoms = map snd xsDoms'
   85             soValues <- sequence [ innerSO downX1 x xDom | (x, xDom) <- zip xs xsDoms ]
   86             return $ AbstractLiteral $ AbsLitTuple soValues
   87