never executed always true always false

    1 {-# LANGUAGE DeriveDataTypeable #-}
    2 {-# LANGUAGE DeriveGeneric #-}
    3 {-# LANGUAGE DeriveTraversable #-}
    4 {-# LANGUAGE InstanceSigs #-}
    5 
    6 module Conjure.Language.Expression.Op.ApplySymmetries where
    7 
    8 import Conjure.Language.Expression.Op.Internal.Common
    9 import Conjure.Prelude
   10 import Data.Aeson qualified as JSON -- aeson
   11 import Data.Aeson.KeyMap qualified as KM
   12 import Data.Vector qualified as V -- vector
   13 
   14 -- Delayed flag, ordered values, and a parameter sequence of permutation tuples.
   15 data OpApplySymmetries x = OpApplySymmetries Bool x x
   16   deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
   17 
   18 instance (Serialize x) => Serialize (OpApplySymmetries x)
   19 
   20 instance (Hashable x) => Hashable (OpApplySymmetries x)
   21 
   22 instance (ToJSON x) => ToJSON (OpApplySymmetries x) where
   23   toJSON :: (ToJSON x) => OpApplySymmetries x -> JSON.Value
   24   toJSON = genericToJSON jsonOptions
   25 
   26 instance (FromJSON x) => FromJSON (OpApplySymmetries x) where parseJSON = genericParseJSON jsonOptions
   27 
   28 instance (TypeOf x, Pretty x, ExpressionLike x) => TypeOf (OpApplySymmetries x) where
   29   typeOf p@(OpApplySymmetries delayed values symmetries) = do
   30     let opName :: Doc
   31         opName = if delayed then "applySymmetriesDelayed" else "applySymmetriesEager"
   32     tv <- typeOf values
   33     ts <- typeOf symmetries
   34     case tv of
   35       TypeTuple _ -> return ()
   36       _ -> raiseTypeError $ opName <+> "expects a tuple of values:" <+> pretty p
   37     entries <- case ts of
   38       TypeSequence (TypeTuple xs) -> return xs
   39       _ -> raiseTypeError $ opName <+> "expects a sequence of permutation tuples:" <+> pretty p
   40     domains <- forM entries $ \t -> case t of
   41       TypePermutation d -> return d
   42       _ -> raiseTypeError $ opName <+> "entry is not a permutation:" <+> pretty p
   43     unless (length domains == length (nub domains)) $
   44       raiseTypeError $ opName <+> "has multiple permutations for the same type:" <+> pretty p
   45     return TypeBool
   46 
   47 instance SimplifyOp OpApplySymmetries x where
   48   simplifyOp _ = na "simplifyOp{OpApplySymmetries}"
   49 
   50 instance Pretty x => Pretty (OpApplySymmetries x) where
   51   prettyPrec _ (OpApplySymmetries delayed values symmetries) =
   52     (if delayed then "applySymmetriesDelayed" else "applySymmetriesEager") <>
   53       prettyList prParens "," [values, symmetries]
   54 
   55 instance (VarSymBreakingDescription x, ExpressionLike x) => VarSymBreakingDescription (OpApplySymmetries x) where
   56   varSymBreakingDescription (OpApplySymmetries delayed values symmetries) = JSON.Object $ KM.fromList
   57     [ ("type", JSON.String (if delayed then "OpApplySymmetriesDelayed" else "OpApplySymmetries"))
   58     , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription [values, symmetries])
   59     ]