never executed always true always false

    1 {-# LANGUAGE DeriveDataTypeable #-}
    2 {-# LANGUAGE DeriveGeneric #-}
    3 {-# LANGUAGE DeriveTraversable #-}
    4 
    5 module Conjure.Language.Expression.Op.Transform where
    6 
    7 import Conjure.Language.Expression.Op.Internal.Common
    8 import Conjure.Prelude
    9 import Data.Aeson qualified as JSON -- aeson
   10 import Data.Aeson.KeyMap qualified as KM
   11 import Data.Vector qualified as V -- vector
   12 
   13 data OpTransform x = OpTransform [x] x
   14   deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
   15 
   16 instance (Serialize x) => Serialize (OpTransform x)
   17 
   18 instance (Hashable x) => Hashable (OpTransform x)
   19 
   20 instance (ToJSON x) => ToJSON (OpTransform x) where toJSON = genericToJSON jsonOptions
   21 
   22 instance (FromJSON x) => FromJSON (OpTransform x) where parseJSON = genericParseJSON jsonOptions
   23 
   24 instance (TypeOf x, Pretty x) => TypeOf (OpTransform x) where
   25   typeOf p@(OpTransform fs x) = do
   26     fromTos <- forM fs $ \f -> do
   27       tyF <- typeOf f
   28       (from, to) <- case tyF of
   29         TypeFunction from to -> return (from, to)
   30         TypeSequence to -> return (TypeInt TagInt, to)
   31         TypePermutation ov -> return (ov, ov)
   32         _ -> raiseTypeError $ "(transform first argument not a morphism)" <+> pretty p
   33       return (from, to)
   34     if typesUnify $ concat [[a, b] | (a, b) <- fromTos]
   35       then typeOf x
   36       else
   37         raiseTypeError
   38           $ vcat
   39             [ pretty p,
   40               "transform morphism not homomorphic!",
   41               "morphisms    :" <+> vcat (map pretty fs)
   42             ]
   43 
   44 instance SimplifyOp OpTransform x where
   45   simplifyOp _ = na "simplifyOp{OpTransform}"
   46 
   47 instance (Pretty x) => Pretty (OpTransform x) where
   48   prettyPrec _ (OpTransform a b) = "transform" <> prettyListDoc prParens "," [prettyList prBrackets "," a, pretty b]
   49 
   50 instance (VarSymBreakingDescription x) => VarSymBreakingDescription (OpTransform x) where
   51   varSymBreakingDescription (OpTransform a b) =
   52     JSON.Object
   53       $ KM.fromList
   54         [ ("type", JSON.String "OpTransform"),
   55           ( "children",
   56             JSON.Array
   57               $ V.fromList
   58                 (map varSymBreakingDescription a ++ [varSymBreakingDescription b])
   59           )
   60         ]