never executed always true always false
1 module Conjure.Language.Expression.Op
2 ( module Conjure.Language.Expression.Op.Internal.Generated
3 , module Conjure.Language.Expression.Op.Internal.Common
4 , mkBinOp, mkOp
5 , OpType (..)
6 ) where
7
8 -- conjure
9 import Conjure.Prelude
10 import Conjure.Bug
11 import Conjure.Language.AdHoc
12 import Conjure.Language.Pretty
13 import Conjure.Language.Lexer
14 import Conjure.Language.Expression.Op.Internal.Common ( simplifyOp
15 , Fixity(..), operators, functionals
16 , EssenceOperatorParsingDescr(..) )
17 import Conjure.Language.Expression.Op.Internal.Generated
18
19
20
21 mkBinOp :: (Op x :< x, ExpressionLike x) => Text -> x -> x -> x
22 mkBinOp op a b =
23 case textToLexeme op of
24 Nothing -> bug ("Unknown binary operator:" <+> pretty op)
25 Just l ->
26 let
27 f = case l of
28 L_Plus -> \ x y -> inject $ MkOpSum $ OpSum $ fromList [x,y]
29 L_Minus -> \ x y -> inject $ MkOpMinus $ OpMinus x y
30 L_Times -> \ x y -> inject $ MkOpProduct $ OpProduct $ fromList [x,y]
31 L_Div -> \ x y -> inject $ MkOpDiv $ OpDiv x y
32 L_Mod -> \ x y -> inject $ MkOpMod $ OpMod x y
33 L_Pow -> \ x y -> inject $ MkOpPow $ OpPow x y
34 L_Eq -> \ x y -> inject $ MkOpEq $ OpEq x y
35 L_Neq -> \ x y -> inject $ MkOpNeq $ OpNeq x y
36 L_Lt -> \ x y -> inject $ MkOpLt $ OpLt x y
37 L_Leq -> \ x y -> inject $ MkOpLeq $ OpLeq x y
38 L_Gt -> \ x y -> inject $ MkOpGt $ OpGt x y
39 L_Geq -> \ x y -> inject $ MkOpGeq $ OpGeq x y
40 L_in -> \ x y -> inject $ MkOpIn $ OpIn x y
41 L_And -> \ x y -> inject $ MkOpAnd $ OpAnd $ fromList [x,y]
42 L_Or -> \ x y -> inject $ MkOpOr $ OpOr $ fromList [x,y]
43 L_Imply -> \ x y -> inject $ MkOpImply $ OpImply x y
44 L_Iff -> \ x y -> inject $ MkOpIff $ OpIff x y
45 L_subset -> \ x y -> inject $ MkOpSubset $ OpSubset x y
46 L_subsetEq -> \ x y -> inject $ MkOpSubsetEq $ OpSubsetEq x y
47 L_supset -> \ x y -> inject $ MkOpSupset $ OpSupset x y
48 L_supsetEq -> \ x y -> inject $ MkOpSupsetEq $ OpSupsetEq x y
49 L_subsequence -> \ x y -> inject $ MkOpSubsequence $ OpSubsequence x y
50 L_substring -> \ x y -> inject $ MkOpSubstring $ OpSubstring x y
51 L_intersect -> \ x y -> inject $ MkOpIntersect $ OpIntersect x y
52 L_union -> \ x y -> inject $ MkOpUnion $ OpUnion x y
53 L_LexLt -> \ x y -> inject $ MkOpLexLt $ OpLexLt x y
54 L_LexLeq -> \ x y -> inject $ MkOpLexLeq $ OpLexLeq x y
55 L_LexGt -> \ x y -> inject $ MkOpLexLt $ OpLexLt y x
56 L_LexGeq -> \ x y -> inject $ MkOpLexLeq $ OpLexLeq y x
57 L_DotLt -> \ x y -> inject $ MkOpDotLt $ OpDotLt x y
58 L_DotLeq -> \ x y -> inject $ MkOpDotLeq $ OpDotLeq x y
59 L_DotGt -> \ x y -> inject $ MkOpDotLt $ OpDotLt y x
60 L_DotGeq -> \ x y -> inject $ MkOpDotLeq $ OpDotLeq y x
61 L_TildeLt -> \ x y -> inject $ MkOpTildeLt $ OpTildeLt x y
62 L_TildeLeq -> \ x y -> inject $ MkOpTildeLeq $ OpTildeLeq x y
63 L_TildeGt -> \ x y -> inject $ MkOpTildeLt $ OpTildeLt y x
64 L_TildeGeq -> \ x y -> inject $ MkOpTildeLeq $ OpTildeLeq y x
65 _ -> bug ("Unknown lexeme for binary operator:" <+> pretty (show l))
66 in
67 f a b
68
69 data OpType
70 = PrefixOp Lexeme
71 | FactorialOp
72 | TwoBarOp
73 | FunctionOp Lexeme
74
75
76 mkOp :: (Op x :< x, ReferenceContainer x, ExpressionLike x) => OpType -> [x] -> x
77 mkOp op xs = case op of
78 PrefixOp lex -> case lex of
79 L_ExclamationMark -> inject $ MkOpNot $ OpNot (arg xs 0 "not")
80 L_Minus -> inject $ MkOpNegate $ OpNegate (arg xs 0 "negate")
81 _ -> bug $ "Unexpected Prefix operator :" <+> pretty (show lex)
82 FactorialOp -> inject $ MkOpFactorial $ OpFactorial (arg xs 0 "factorial")
83 TwoBarOp -> inject $ MkOpTwoBars $ OpTwoBars (arg xs 0 "twoBars")
84 FunctionOp lex -> case lex of
85 L_fAnd -> inject $ MkOpAnd $ OpAnd (arg xs 0 "and")
86 L_fOr -> inject $ MkOpOr $ OpOr (arg xs 0 "or")
87 L_fXor -> inject $ MkOpXor $ OpXor (arg xs 0 "xor")
88 L_Sum -> inject $ MkOpSum $ OpSum (arg xs 0 "sum")
89 L_Product -> inject $ MkOpProduct $ OpProduct (arg xs 0 "product")
90 -- _ -> opImage (fromName (Name op)) xs
91 L_true -> inject $ MkOpTrue $ OpTrue (arg xs 0 "true")
92 L_toInt -> inject $ MkOpToInt $ OpToInt (arg xs 0 "toInt")
93 L_makeTable -> inject $ MkOpMakeTable $ OpMakeTable (arg xs 0 "makeTable")
94 L_table -> inject $ MkOpTable $ OpTable (arg xs 0 "table") (arg xs 1 "table")
95 L_gcc -> inject $ MkOpGCC $ OpGCC (arg xs 0 "gcc") (arg xs 1 "gcc") (arg xs 2 "gcc")
96 L_atleast -> inject $ MkOpAtLeast $ OpAtLeast (arg xs 0 "atleast") (arg xs 1 "atleast") (arg xs 2 "atleast")
97 L_atmost -> inject $ MkOpAtMost $ OpAtMost (arg xs 0 "atmost" ) (arg xs 1 "atmost" ) (arg xs 2 "atmost" )
98 L_defined -> inject $ MkOpDefined $ OpDefined (arg xs 0 "defined")
99 L_range -> inject $ MkOpRange $ OpRange (arg xs 0 "range")
100 L_restrict -> inject $ MkOpRestrict $ OpRestrict (arg xs 0 "restrict") (arg xs 1 "restrict")
101 L_allDiff -> inject $ MkOpAllDiff $ OpAllDiff (arg xs 0 "allDiff")
102 L_alldifferent_except -> inject $ MkOpAllDiffExcept $ OpAllDiffExcept
103 (arg xs 0 "allDiffExcept")
104 (arg xs 1 "allDiffExcept")
105 L_catchUndef -> inject $ MkOpCatchUndef $ OpCatchUndef (arg xs 0 "catchUndef")
106 (arg xs 1 "catchUndef")
107 L_dontCare -> inject $ MkOpDontCare $ OpDontCare (arg xs 0 "dontCare")
108 L_toSet -> inject $ MkOpToSet $ OpToSet False (arg xs 0 "toSet")
109 L_toMSet -> inject $ MkOpToMSet $ OpToMSet (arg xs 0 "toMSet")
110 L_toRelation -> inject $ MkOpToRelation $ OpToRelation (arg xs 0 "toRelation")
111 L_max -> inject $ MkOpMax $ OpMax (arg xs 0 "max")
112 L_min -> inject $ MkOpMin $ OpMin (arg xs 0 "min")
113 L_image -> inject $ MkOpImage $ OpImage (arg xs 0 "image")
114 (arg xs 1 "image")
115 L_transform -> inject $ MkOpTransform $ OpTransform (arg xs 0 "transform")
116 (arg xs 1 "transform")
117
118 L_imageSet -> inject $ MkOpImageSet $ OpImageSet (arg xs 0 "imageSet")
119 (arg xs 1 "imageSet")
120 L_preImage -> inject $ MkOpPreImage $ OpPreImage (arg xs 0 "preImage")
121 (arg xs 1 "preImage")
122 L_inverse -> inject $ MkOpInverse $ OpInverse (arg xs 0 "inverse")
123 (arg xs 1 "inverse")
124 L_freq -> inject $ MkOpFreq $ OpFreq (arg xs 0 "freq")
125 (arg xs 1 "freq")
126 L_hist -> inject $ MkOpHist $ OpHist (arg xs 0 "hist")
127 L_parts -> inject $ MkOpParts $ OpParts (arg xs 0 "parts")
128 L_together -> inject $ MkOpTogether $ OpTogether (arg xs 0 "together")
129 (arg xs 1 "together")
130 L_apart -> inject $ MkOpApart $ OpApart (arg xs 0 "apart")
131 (arg xs 1 "apart")
132 L_party -> inject $ MkOpParty $ OpParty (arg xs 0 "party")
133 (arg xs 1 "party")
134 L_participants -> inject $ MkOpParticipants $ OpParticipants (arg xs 0 "participants")
135 L_active -> inject $ MkOpActive $ OpActive (arg xs 0 "active")
136 (arg xs 1 "active" |> nameOut |> fromMaybe (bug "active"))
137 L_pred -> inject $ MkOpPred $ OpPred (arg xs 0 "pred")
138 L_succ -> inject $ MkOpSucc $ OpSucc (arg xs 0 "succ")
139 L_factorial -> inject $ MkOpFactorial $ OpFactorial (arg xs 0 "factorial")
140 L_powerSet -> inject $ MkOpPowerSet $ OpPowerSet (arg xs 0 "powerSet")
141 L_concatenate -> inject $ MkOpFlatten $ OpFlatten (Just 1)
142 (arg xs 0 "concatenate")
143 L_flatten ->
144 case xs of
145 [m] -> inject $ MkOpFlatten $ OpFlatten Nothing m
146 [n,m] ->
147 let n' = fromInteger $ fromMaybe (bug "The 1st argument of flatten has to be a constant integer.") (intOut "flatten" n)
148 in inject $ MkOpFlatten $ OpFlatten (Just n') m
149 _ -> bug "flatten takes 1 or 2 arguments."
150 _ -> bug ("Unknown lexeme for function type operator:" <+> pretty (show lex))
151
152
153 arg :: [a] -> Int -> Doc -> a
154 arg xs n op =
155 case atMay xs n of
156 Nothing -> bug ("Missing argument" <+> pretty (n+1) <+> "for operator" <+> op)
157 Just v -> v