never executed always true always false

    1 {-# LANGUAGE QuasiQuotes #-}
    2 
    3 module Conjure.Rules.Vertical.Record where
    4 
    5 import Conjure.Rules.Import
    6 import Conjure.Rules.Vertical.Tuple ( decomposeLexLt, decomposeLexLeq  )
    7 
    8 -- containers
    9 import qualified Data.Map.Strict as M ( fromList, (!) )
   10 
   11 
   12 -- | sort the ys list (which correspond to keys in the yFields list)
   13 --   in a way which corresponds to the keys in the xFields list.
   14 sortByFields :: [(Name, t)] -> [(Name, t)] -> [x] -> [x]
   15 sortByFields xFields yFields ys =
   16     let ysMap = M.fromList $ zip (map fst yFields) ys
   17     in  [ ysMap M.! xField | (xField, _) <- xFields ]
   18 
   19 rule_Record_Eq :: Rule
   20 rule_Record_Eq = "record-eq" `namedRule` theRule where
   21     theRule p = do
   22         (x,y)              <- match opEq p
   23         TypeRecord xFields <- typeOf x
   24         TypeRecord yFields <- typeOf y
   25         xs                 <- downX1 x
   26         ys                 <- sortByFields xFields yFields <$> downX1 y
   27         return
   28             ( "Horizontal rule for record equality"
   29             , return $ make opAnd $ fromList $ zipWith (make opEq) xs ys
   30             )
   31 
   32 
   33 rule_Record_Neq :: Rule
   34 rule_Record_Neq = "record-neq" `namedRule` theRule where
   35     theRule p = do
   36         (x,y)              <- match opNeq p
   37         TypeRecord xFields <- typeOf x
   38         TypeRecord yFields <- typeOf y
   39         xs                 <- downX1 x
   40         ys                 <- sortByFields xFields yFields <$> downX1 y
   41         return
   42             ( "Horizontal rule for record !="
   43             , return $ make opNot $ make opAnd $ fromList $ zipWith (make opEq) xs ys
   44             )
   45 
   46 
   47 rule_Record_Lt :: Rule
   48 rule_Record_Lt = "record-Lt" `namedRule` theRule where
   49     theRule p = do
   50         (x,y)              <- match opLt p
   51         TypeRecord xFields <- typeOf x
   52         TypeRecord yFields <- typeOf y
   53         xs                 <- downX1 x
   54         ys                 <- sortByFields xFields yFields <$> downX1 y
   55         return
   56             ( "Horizontal rule for record <"
   57             , return $ decomposeLexLt p xs ys
   58             )
   59 
   60 
   61 rule_Record_Leq :: Rule
   62 rule_Record_Leq = "record-Leq" `namedRule` theRule where
   63     theRule p = do
   64         (x,y)              <- match opLeq p
   65         TypeRecord xFields <- typeOf x
   66         TypeRecord yFields <- typeOf y
   67         xs                 <- downX1 x
   68         ys                 <- sortByFields xFields yFields <$> downX1 y
   69         return
   70             ( "Horizontal rule for record <="
   71             , return $ decomposeLexLeq p xs ys
   72             )
   73 
   74 
   75 rule_Record_Index :: Rule
   76 rule_Record_Index = "record-index" `namedRule` theRule where
   77     theRule p = do
   78         (t,i)         <- match opIndexing p
   79         TypeRecord ds <- typeOf t
   80         name          <- nameOut i
   81         iInt          <- case elemIndex name (map fst ds) of
   82                             Nothing   -> failDoc "Record indexing, not a member of the type."
   83                             Just iInt -> return iInt
   84         ts            <- downX1 t
   85         return
   86             ( "Record indexing on:" <+> pretty p
   87             , return $ atNote "Record indexing" ts iInt
   88             )