never executed always true always false
1 module Conjure.Language.AdHoc where
2
3 import Conjure.Prelude
4 import Conjure.UserError
5 import Conjure.Language.Type
6 import Conjure.Language.Name
7 import Conjure.Language.Pretty
8
9 -- aeson
10 import qualified Data.Aeson as JSON
11
12 import qualified Data.Vector as V -- vector
13
14 -- scientific
15 import Data.Scientific ( floatingOrInteger )
16 import qualified Data.Aeson.KeyMap as KM
17
18
19
20 class ExpressionLike a where
21 fromInt :: Integer -> a
22 fromIntWithTag :: Integer -> IntTag -> a
23 intOut :: MonadFailDoc m => Doc -> a -> m Integer
24
25 fromBool :: Bool -> a
26 boolOut :: MonadFailDoc m => a -> m Bool
27
28 fromList :: [a] -> a
29 listOut :: MonadFailDoc m => a -> m [a]
30
31 class ReferenceContainer a where
32 fromName :: Name -> a
33 nameOut :: MonadFailDoc m => a -> m Name
34
35 class DomainContainer a dom where
36 fromDomain :: dom a -> a
37 domainOut :: MonadFailDoc m => a -> m (dom a)
38
39 class CanBeAnAlias a where
40 isAlias :: a -> Maybe a
41
42 class VarSymBreakingDescription a where
43 varSymBreakingDescription :: a -> JSON.Value
44
45 class (:<) a b where
46 inject :: a -> b
47 project :: MonadFailDoc m => b -> m a
48
49 data MiniZincData = MZNBool Bool
50 | MZNInt Integer
51 | MZNArray (Maybe String) [MiniZincData] -- index if any, then data
52 | MZNSet [MiniZincData]
53 | MZNNamed [(Name, MiniZincData)]
54 deriving (Eq, Ord, Show)
55
56 instance Pretty MiniZincData where
57 pretty (MZNBool x) = pretty x
58 pretty (MZNInt x) = pretty x
59 pretty (MZNArray index xs) =
60 let
61 nestedPretty (MZNArray _ ys) = prettyList id "," ys
62 nestedPretty y = pretty y
63
64 fillNothingIndices (MZNArray Nothing ys) = MZNArray (Just $ "1.." ++ show (length ys)) (map fillNothingIndices ys)
65 fillNothingIndices (MZNArray (Just index2) ys) = MZNArray (Just index2) (map fillNothingIndices ys)
66 fillNothingIndices m@MZNBool{} = m
67 fillNothingIndices m@MZNInt{} = m
68 fillNothingIndices (MZNSet ys) = MZNSet (map fillNothingIndices ys)
69 fillNothingIndices (MZNNamed ys) = MZNNamed [(n, fillNothingIndices y) | (n, y) <- ys]
70
71 calcIndices (MZNArray index2 []) = [index2]
72 calcIndices (MZNArray index2 (y:_)) = index2 : calcIndices y
73 calcIndices _ = []
74
75 indices = calcIndices $ fillNothingIndices $ MZNArray index xs
76 depth = length indices
77
78 args = [pretty i | Just i <- indices] ++ [prettyList prBrackets "," (map nestedPretty xs)]
79 in
80 "array" <> pretty depth <> "d" <> prettyList prParens "," args
81 pretty (MZNSet xs) = prettyList prBraces "," (map pretty xs)
82 pretty (MZNNamed xs) = vcat [pretty n <+> "=" <+> pretty x <> ";" | (n,x) <- xs]
83
84
85 expressionDepth :: Data a => a -> Int
86 expressionDepth x = 1 + maximum (0 : map expressionDepth (children x))
87
88
89 class ToFromMiniZinc a where
90 toMiniZinc :: MonadUserError m => a -> m MiniZincData
91 -- this is what we would use to support data files
92 -- fromMiniZinc :: MonadUserError m => M.HashMap Name MiniZincData -> m a
93
94 noToMiniZinc :: (MonadUserError m, Pretty a) => a -> m b
95 noToMiniZinc a = userErr1 $ vcat
96 [ "Cannot convert the following to MiniZinc syntax:"
97 , ""
98 , pretty (show a)
99 , pretty a
100 , ""
101 , "Let us know if you need support for this please!"
102 , "As a workaround you can use --output-format=json"
103 ]
104
105 class SimpleJSON a where
106 toSimpleJSON :: (MonadFail m,MonadUserError m) => a -> m JSON.Value
107 fromSimpleJSON ::(MonadFail m, MonadUserError m) => Type -> JSON.Value -> m a
108
109 instance SimpleJSON Integer where
110 toSimpleJSON = return . toJSON
111 fromSimpleJSON t x =
112 case x of
113 JSON.Number y ->
114 case floatingOrInteger y of
115 Right z -> return z
116 Left (d :: Double) -> noFromSimpleJSON "Integer" t d
117 JSON.String text ->
118 case readMay (textToString text) of
119 Just z -> return z
120 Nothing -> noFromSimpleJSON "Integer" t text
121 _ -> noFromSimpleJSON "Integer" t x
122
123 newtype AsDictionary a b = AsDictionary [(a,b)]
124
125 instance (Pretty x, SimpleJSON x, SimpleJSON y) => SimpleJSON (AsDictionary x y) where
126 toSimpleJSON (AsDictionary xs) = do
127 (ys, asList) <- fmap unzip $ forM xs $ \ (a,b) -> do
128 let aStr = fromString $ renderNormal $ pretty a
129 aJSON <- toSimpleJSON a
130 bJSON <- toSimpleJSON b
131 let abPair = JSON.Array $ V.fromList [aJSON, bJSON]
132 case aJSON of
133 JSON.Bool{} -> return (Just (aStr, bJSON), abPair)
134 JSON.Number{} -> return (Just (aStr, bJSON), abPair)
135 JSON.String{} -> return (Just (aStr, bJSON), abPair)
136 _ -> return (Nothing , abPair)
137 let zs = catMaybes ys
138 if length ys == length zs
139 -- all were suitable as keys, great
140 then return $ JSON.Object $ KM.fromList zs
141 else return $ JSON.Array $ V.fromList asList
142 fromSimpleJSON = noFromSimpleJSON "AsDictionary"
143
144 instance SimpleJSON x => SimpleJSON [x] where
145 toSimpleJSON xs = do
146 ys <- mapM toSimpleJSON xs
147 return $ JSON.Array $ V.fromList ys
148 fromSimpleJSON = noFromSimpleJSON "list"
149
150 instance (SimpleJSON x, SimpleJSON y) => SimpleJSON (x,y) where
151 toSimpleJSON (x,y) = do
152 x' <- toSimpleJSON x
153 y' <- toSimpleJSON y
154 return $ JSON.Array $ V.fromList [x', y']
155 fromSimpleJSON = noFromSimpleJSON "pair"
156
157
158 noToSimpleJSON :: (MonadUserError m, Pretty a) => a -> m b
159 noToSimpleJSON a = userErr1 $ vcat
160 [ "Cannot convert the following to simple JSON:"
161 , ""
162 , pretty a
163 , ""
164 , "Let us know if you need support for this please!"
165 , "As a workaround you can use --output-format=astjson"
166 ]
167
168
169 noFromSimpleJSON :: (MonadUserError m, Pretty a, Show a, Pretty b, Show b) => String -> a -> b -> m c
170 noFromSimpleJSON src ty x = userErr1 $ vcat
171 [ "Cannot convert this JSON to Essence yet."
172 , ""
173 , pretty ty
174 , pretty (show ty)
175 , ""
176 , pretty x
177 , pretty (show x)
178 , ""
179 , "Source:" <+> pretty src
180 , ""
181 , "Let us know if you need support for this please!"
182 , "As a workaround you can use --output-format=astjson"
183 ]
184