never executed always true always false
1 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DeriveFunctor, DeriveTraversable, DeriveFoldable #-}
2
3 module Conjure.Language.Expression.Op.PreImage where
4
5 import Conjure.Prelude
6 import Conjure.Language.Expression.Op.Internal.Common
7
8 import qualified Data.Aeson as JSON -- aeson
9 import qualified Data.Aeson.KeyMap as KM
10
11 import qualified Data.Vector as V -- vector
12
13
14 data OpPreImage x = OpPreImage x x
15 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
16
17 instance Serialize x => Serialize (OpPreImage x)
18 instance Hashable x => Hashable (OpPreImage x)
19 instance ToJSON x => ToJSON (OpPreImage x) where toJSON = genericToJSON jsonOptions
20 instance FromJSON x => FromJSON (OpPreImage x) where parseJSON = genericParseJSON jsonOptions
21
22 instance (TypeOf x, Pretty x) => TypeOf (OpPreImage x) where
23 typeOf p@(OpPreImage f x) = do
24 fTy <- typeOf f
25 xTy <- typeOf x
26 case fTy of
27 TypeFunction from to -> do
28 if typesUnify [xTy, to]
29 then return (TypeSet from)
30 else raiseTypeError p
31 TypeSequence to -> do
32 if typesUnify [xTy, to]
33 then return (TypeSet (TypeInt TagInt))
34 else raiseTypeError p
35 _ -> raiseTypeError p
36
37 instance SimplifyOp OpPreImage x where
38 simplifyOp _ = na "simplifyOp{OpPreImage}"
39
40 instance Pretty x => Pretty (OpPreImage x) where
41 prettyPrec _ (OpPreImage a b) = "preImage" <> prettyList prParens "," [a,b]
42
43 instance VarSymBreakingDescription x => VarSymBreakingDescription (OpPreImage x) where
44 varSymBreakingDescription (OpPreImage a b) = JSON.Object $ KM.fromList
45 [ ("type", JSON.String "OpPreImage")
46 , ("children", JSON.Array $ V.fromList
47 [ varSymBreakingDescription a
48 , varSymBreakingDescription b
49 ])
50 ]