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_elementId -> inject $ MkOpElementId $ OpElementId (arg xs 0 "elementId") (arg xs 1 "elementId")
97 L_atleast -> inject $ MkOpAtLeast $ OpAtLeast (arg xs 0 "atleast") (arg xs 1 "atleast") (arg xs 2 "atleast")
98 L_atmost -> inject $ MkOpAtMost $ OpAtMost (arg xs 0 "atmost" ) (arg xs 1 "atmost" ) (arg xs 2 "atmost" )
99 L_defined -> inject $ MkOpDefined $ OpDefined (arg xs 0 "defined")
100 L_range -> inject $ MkOpRange $ OpRange (arg xs 0 "range")
101 L_restrict -> inject $ MkOpRestrict $ OpRestrict (arg xs 0 "restrict") (arg xs 1 "restrict")
102 L_allDiff -> inject $ MkOpAllDiff $ OpAllDiff (arg xs 0 "allDiff")
103 L_alldifferent_except -> inject $ MkOpAllDiffExcept $ OpAllDiffExcept
104 (arg xs 0 "allDiffExcept")
105 (arg xs 1 "allDiffExcept")
106 L_catchUndef -> inject $ MkOpCatchUndef $ OpCatchUndef (arg xs 0 "catchUndef")
107 (arg xs 1 "catchUndef")
108 L_quickPermutationOrder -> inject $ MkOpQuickPermutationOrder $ OpQuickPermutationOrder (arg xs 0 "quickPermutationOrder" |> listOut |> fromMaybe (bug "")) (arg xs 1 "quickPermutationOrder")
109 L_dontCare -> inject $ MkOpDontCare $ OpDontCare (arg xs 0 "dontCare")
110 L_toSet -> inject $ MkOpToSet $ OpToSet False (arg xs 0 "toSet")
111 L_toMSet -> inject $ MkOpToMSet $ OpToMSet (arg xs 0 "toMSet")
112 L_toRelation -> inject $ MkOpToRelation $ OpToRelation (arg xs 0 "toRelation")
113 L_max -> inject $ MkOpMax $ OpMax (arg xs 0 "max")
114 L_min -> inject $ MkOpMin $ OpMin (arg xs 0 "min")
115 L_image -> inject $ MkOpImage $ OpImage (arg xs 0 "image")
116 (arg xs 1 "image")
117 L_transform -> inject $ MkOpTransform $ OpTransform (arg xs 0 "transform" |> listOut |> fromMaybe (bug ""))
118 (arg xs 1 "transform")
119
120 L_imageSet -> inject $ MkOpImageSet $ OpImageSet (arg xs 0 "imageSet")
121 (arg xs 1 "imageSet")
122 L_preImage -> inject $ MkOpPreImage $ OpPreImage (arg xs 0 "preImage")
123 (arg xs 1 "preImage")
124 L_inverse -> inject $ MkOpInverse $ OpInverse (arg xs 0 "inverse")
125 (arg xs 1 "inverse")
126 L_freq -> inject $ MkOpFreq $ OpFreq (arg xs 0 "freq")
127 (arg xs 1 "freq")
128 L_hist -> inject $ MkOpHist $ OpHist (arg xs 0 "hist")
129 L_parts -> inject $ MkOpParts $ OpParts (arg xs 0 "parts")
130 L_together -> inject $ MkOpTogether $ OpTogether (arg xs 0 "together")
131 (arg xs 1 "together")
132 L_apart -> inject $ MkOpApart $ OpApart (arg xs 0 "apart")
133 (arg xs 1 "apart")
134 L_party -> inject $ MkOpParty $ OpParty (arg xs 0 "party")
135 (arg xs 1 "party")
136 L_permInverse -> inject $ MkOpPermInverse $ OpPermInverse (arg xs 0 "permInverse")
137 L_participants -> inject $ MkOpParticipants $ OpParticipants (arg xs 0 "participants")
138 L_compose -> inject $ MkOpCompose $ OpCompose (arg xs 0 "compose")
139 (arg xs 1 "compose")
140
141 L_active -> inject $ MkOpActive $ OpActive (arg xs 0 "active")
142 (arg xs 1 "active" |> nameOut |> fromMaybe (bug "active"))
143 L_pred -> inject $ MkOpPred $ OpPred (arg xs 0 "pred")
144 L_succ -> inject $ MkOpSucc $ OpSucc (arg xs 0 "succ")
145 L_factorial -> inject $ MkOpFactorial $ OpFactorial (arg xs 0 "factorial")
146 L_powerSet -> inject $ MkOpPowerSet $ OpPowerSet (arg xs 0 "powerSet")
147 L_concatenate -> inject $ MkOpFlatten $ OpFlatten (Just 1)
148 (arg xs 0 "concatenate")
149 L_flatten ->
150 case xs of
151 [m] -> inject $ MkOpFlatten $ OpFlatten Nothing m
152 [n,m] ->
153 let n' = fromInteger $ fromMaybe (bug "The 1st argument of flatten has to be a constant integer.") (intOut "flatten" n)
154 in inject $ MkOpFlatten $ OpFlatten (Just n') m
155 _ -> bug "flatten takes 1 or 2 arguments."
156 _ -> bug ("Unknown lexeme for function type operator:" <+> pretty (show lex))
157
158
159 arg :: [a] -> Int -> Doc -> a
160 arg xs n op =
161 case atMay xs n of
162 Nothing -> bug ("Missing argument" <+> pretty (n+1) <+> "for operator" <+> op)
163 Just v -> v