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 class ToFromMiniZinc a where
85 toMiniZinc :: MonadUserError m => a -> m MiniZincData
86 -- this is what we would use to support data files
87 -- fromMiniZinc :: MonadUserError m => M.HashMap Name MiniZincData -> m a
88
89 noToMiniZinc :: (MonadUserError m, Pretty a) => a -> m b
90 noToMiniZinc a = userErr1 $ vcat
91 [ "Cannot convert the following to MiniZinc syntax:"
92 , ""
93 , pretty (show a)
94 , pretty a
95 , ""
96 , "Let us know if you need support for this please!"
97 , "As a workaround you can use --output-format=json"
98 ]
99
100 class SimpleJSON a where
101 toSimpleJSON :: (MonadFail m,MonadUserError m) => a -> m JSON.Value
102 fromSimpleJSON ::(MonadFail m, MonadUserError m) => Type -> JSON.Value -> m a
103
104 instance SimpleJSON Integer where
105 toSimpleJSON = return . toJSON
106 fromSimpleJSON t x =
107 case x of
108 JSON.Number y ->
109 case floatingOrInteger y of
110 Right z -> return z
111 Left (d :: Double) -> noFromSimpleJSON "Integer" t d
112 JSON.String text ->
113 case readMay (textToString text) of
114 Just z -> return z
115 Nothing -> noFromSimpleJSON "Integer" t text
116 _ -> noFromSimpleJSON "Integer" t x
117
118 newtype AsDictionary a b = AsDictionary [(a,b)]
119
120 instance (Pretty x, SimpleJSON x, SimpleJSON y) => SimpleJSON (AsDictionary x y) where
121 toSimpleJSON (AsDictionary xs) = do
122 (ys, asList) <- fmap unzip $ forM xs $ \ (a,b) -> do
123 let aStr = fromString $ renderNormal $ pretty a
124 aJSON <- toSimpleJSON a
125 bJSON <- toSimpleJSON b
126 let abPair = JSON.Array $ V.fromList [aJSON, bJSON]
127 case aJSON of
128 JSON.Bool{} -> return (Just (aStr, bJSON), abPair)
129 JSON.Number{} -> return (Just (aStr, bJSON), abPair)
130 JSON.String{} -> return (Just (aStr, bJSON), abPair)
131 _ -> return (Nothing , abPair)
132 let zs = catMaybes ys
133 if length ys == length zs
134 -- all were suitable as keys, great
135 then return $ JSON.Object $ KM.fromList zs
136 else return $ JSON.Array $ V.fromList asList
137 fromSimpleJSON = noFromSimpleJSON "AsDictionary"
138
139 instance SimpleJSON x => SimpleJSON [x] where
140 toSimpleJSON xs = do
141 ys <- mapM toSimpleJSON xs
142 return $ JSON.Array $ V.fromList ys
143 fromSimpleJSON = noFromSimpleJSON "list"
144
145 instance (SimpleJSON x, SimpleJSON y) => SimpleJSON (x,y) where
146 toSimpleJSON (x,y) = do
147 x' <- toSimpleJSON x
148 y' <- toSimpleJSON y
149 return $ JSON.Array $ V.fromList [x', y']
150 fromSimpleJSON = noFromSimpleJSON "pair"
151
152
153 noToSimpleJSON :: (MonadUserError m, Pretty a) => a -> m b
154 noToSimpleJSON a = userErr1 $ vcat
155 [ "Cannot convert the following to simple JSON:"
156 , ""
157 , pretty a
158 , ""
159 , "Let us know if you need support for this please!"
160 , "As a workaround you can use --output-format=astjson"
161 ]
162
163
164 noFromSimpleJSON :: (MonadUserError m, Pretty a, Show a, Pretty b, Show b) => String -> a -> b -> m c
165 noFromSimpleJSON src ty x = userErr1 $ vcat
166 [ "Cannot convert this JSON to Essence yet."
167 , ""
168 , pretty ty
169 , pretty (show ty)
170 , ""
171 , pretty x
172 , pretty (show x)
173 , ""
174 , "Source:" <+> pretty src
175 , ""
176 , "Let us know if you need support for this please!"
177 , "As a workaround you can use --output-format=astjson"
178 ]
179