never executed always true always false

    1 {-# LANGUAGE QuasiQuotes #-}
    2 
    3 module Conjure.Representations.Record
    4     ( record
    5     ) where
    6 
    7 -- conjure
    8 import Conjure.Prelude
    9 import Conjure.Bug
   10 import Conjure.Language
   11 import Conjure.Representations.Internal
   12 
   13 
   14 record :: forall m . (MonadFailDoc m, NameGen m) => Representation m
   15 record = Representation chck downD structuralCons downC up symmetryOrdering
   16 
   17     where
   18 
   19         chck :: TypeOf_ReprCheck m
   20         chck f (DomainRecord ds) = do
   21             let names = map fst ds
   22             outDoms <- sequence <$> mapM (f . snd) ds
   23             return [ DomainRecord (zip names ds') | ds' <- outDoms ]
   24         chck _ _ = return []
   25 
   26         mkName name n = mconcat [name, "_", n]
   27 
   28         downD :: TypeOf_DownD m
   29         downD (name, DomainRecord ds) = return $ Just
   30             [ (mkName name n, d)
   31             | (n,d) <- ds
   32             ]
   33         downD _ = na "{downD}"
   34 
   35         structuralCons :: TypeOf_Structural m
   36         structuralCons f downX1 (DomainRecord ds) = return $ \ tup -> do
   37             refs <- downX1 tup
   38             concat <$> sequence
   39                 [ do
   40                     innerStructuralConsGen <- f dom
   41                     outs                   <- innerStructuralConsGen ref
   42                     return outs
   43                 | (ref, (_n, dom)) <- zip refs ds
   44                 ]
   45         structuralCons _ _ _ = na "{structuralCons} record"
   46 
   47         -- TODO: check if (length ds == length cs)
   48         downC :: TypeOf_DownC m
   49         downC (name, DomainRecord ds, ConstantAbstract (AbsLitRecord cs))
   50             | sort (map fst ds) == sort (map fst cs) = return $ Just
   51                 [ case lookup n cs of
   52                     Nothing -> bug "Record.downC"
   53                     Just c  -> (mkName name n, d, c)
   54                 | (n,d) <- ds
   55                 ]
   56         downC (n, d, c) =
   57             na $ "{downC} record" <+> vcat
   58                 [ "name  :" <+> pretty n
   59                 , "domain:" <+> pretty d
   60                 , "value :" <+> pretty c
   61                 ]
   62 
   63         up :: TypeOf_Up m
   64         up ctxt (name, DomainRecord ds) = do
   65             let names = map (mkName name . fst) ds
   66             vals <- forM names $ \ n ->
   67                 case lookup n ctxt of
   68                     Nothing -> failDoc $ vcat $
   69                         [ "(in Record up)"
   70                         , "No value for:" <+> pretty n
   71                         , "When working on:" <+> pretty name
   72                         , "With domain:" <+> pretty (DomainRecord ds)
   73                         ] ++
   74                         ("Bindings in context:" : prettyContext ctxt)
   75                     Just val -> return (n, val)
   76             -- TODO: check if (length ds == length vals)
   77             return (name, ConstantAbstract (AbsLitRecord 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