never executed always true always false
1 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DeriveFunctor, DeriveTraversable, DeriveFoldable #-}
2
3 module Conjure.Language.AbstractLiteral where
4
5 -- conjure
6 import Conjure.Prelude
7 import Conjure.Bug
8 import Conjure.UserError ( failToUserError )
9 import Conjure.Language.Name
10 import Conjure.Language.Domain
11 import Conjure.Language.Type
12 import Conjure.Language.AdHoc
13
14 import Conjure.Language.TypeOf
15 import Conjure.Language.Pretty
16
17 -- aeson
18 import qualified Data.Aeson as JSON
19 import qualified Data.Aeson.KeyMap as KM
20 import qualified Data.Vector as V -- vector
21
22
23 data AbstractLiteral x
24 = AbsLitTuple [x]
25 | AbsLitRecord [(Name, x)]
26 | AbsLitVariant (Maybe [(Name, Domain () x)]) Name x -- Nothing before name resolution
27 | AbsLitMatrix (Domain () x) [x] -- the domain is the index domain
28 | AbsLitSet [x]
29 | AbsLitMSet [x]
30 | AbsLitFunction [(x, x)]
31 | AbsLitSequence [x]
32 | AbsLitRelation [[x]]
33 | AbsLitPartition [[x]]
34 | AbsLitPermutation [[x]]
35 deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
36
37 instance Serialize x => Serialize (AbstractLiteral x)
38 instance Hashable x => Hashable (AbstractLiteral x)
39 instance ToJSON x => ToJSON (AbstractLiteral x) where toJSON = genericToJSON jsonOptions
40 instance FromJSON x => FromJSON (AbstractLiteral x) where parseJSON = genericParseJSON jsonOptions
41
42 instance (SimpleJSON x, Pretty x, ExpressionLike x) => SimpleJSON (AbstractLiteral x) where
43 toSimpleJSON lit =
44 case lit of
45 AbsLitTuple xs -> toSimpleJSON xs
46 AbsLitRecord xs -> do
47 xs' <- forM xs $ \ (nm, x) -> do
48 x' <- toSimpleJSON x
49 return (fromString (renderNormal nm), x')
50 return $ JSON.Object $ KM.fromList xs'
51 AbsLitVariant _ nm x -> do
52 x' <- toSimpleJSON x
53 return $ JSON.Object $ KM.fromList [(fromString (renderNormal nm), x')]
54 AbsLitSequence xs -> toSimpleJSON xs
55 AbsLitMatrix index xs ->
56 case index of
57 DomainInt _ ranges -> do
58 indices <- failToUserError $ rangesInts ranges
59 toSimpleJSON (AsDictionary (zip indices xs))
60 _ -> toSimpleJSON xs
61 AbsLitSet xs -> toSimpleJSON xs
62 AbsLitMSet xs -> toSimpleJSON xs
63 AbsLitFunction xs -> toSimpleJSON (AsDictionary xs)
64 AbsLitRelation xs -> toSimpleJSON xs
65 AbsLitPartition xs -> toSimpleJSON xs
66 AbsLitPermutation xs -> toSimpleJSON xs
67 fromSimpleJSON = noFromSimpleJSON "AbstractLiteral"
68
69 instance (ToFromMiniZinc x, Pretty x, ExpressionLike x) => ToFromMiniZinc (AbstractLiteral x) where
70 toMiniZinc lit =
71 case lit of
72 AbsLitTuple xs -> MZNArray Nothing <$> mapM toMiniZinc xs
73 AbsLitMatrix (DomainInt _ [RangeSingle r]) xs -> MZNArray (Just $ show $ pretty r <> ".." <> pretty r) <$> mapM toMiniZinc xs
74 AbsLitMatrix (DomainInt _ [r]) xs -> MZNArray (Just $ show $ pretty r) <$> mapM toMiniZinc xs
75 AbsLitMatrix _index xs -> MZNArray Nothing <$> mapM toMiniZinc xs
76 AbsLitSet xs ->
77 case xs of
78 [] -> return $ MZNSet []
79 (x:_) | Just _ <- intOut "toMiniZinc" x -> MZNSet <$> mapM toMiniZinc xs
80 _ -> MZNArray Nothing <$> mapM toMiniZinc xs
81 AbsLitMSet xs -> MZNArray Nothing <$> mapM toMiniZinc xs
82 AbsLitFunction xs -> MZNArray Nothing <$> mapM (toMiniZinc . snd) xs
83 AbsLitSequence xs -> MZNArray Nothing <$> mapM toMiniZinc xs
84 AbsLitRelation xss ->
85 MZNArray Nothing <$> forM xss (\ xs ->
86 MZNArray Nothing <$> mapM toMiniZinc xs)
87 AbsLitPartition xss ->
88 MZNArray Nothing <$> forM xss (\ xs ->
89 MZNArray Nothing <$> mapM toMiniZinc xs)
90 _ -> noToMiniZinc lit
91
92 instance Pretty a => Pretty (AbstractLiteral a) where
93 pretty (AbsLitTuple xs) = (if length xs < 2 then "tuple" else prEmpty) <+> prettyList prParens "," xs
94 pretty (AbsLitRecord xs) = "record" <+> prettyList prBraces "," [ pretty n <+> "=" <++> pretty x
95 | (n,x) <- xs ]
96 pretty (AbsLitVariant _ n x) = "variant" <+> prBraces (pretty n <+> "=" <+> pretty x)
97 pretty (AbsLitMatrix _ []) = "[]"
98 pretty (AbsLitMatrix index xs) = let f i = prBrackets (i <> ";" <++> pretty index) in prettyList f "," xs
99 pretty (AbsLitSet xs ) = prettyList prBraces "," xs
100 pretty (AbsLitMSet xs ) = "mset" <> prettyList prParens "," xs
101 pretty (AbsLitFunction xs ) = "function" <> prettyListDoc prParens "," [ pretty a <++> "-->" <+> pretty b | (a,b) <- xs ]
102 pretty (AbsLitSequence xs ) = "sequence" <> prettyList prParens "," xs
103 pretty (AbsLitRelation xss) = "relation" <> prettyListDoc prParens "," [ pretty (AbsLitTuple xs) | xs <- xss ]
104 pretty (AbsLitPartition xss) = "partition" <> prettyListDoc prParens "," [ prettyList prBraces "," xs | xs <- xss ]
105 pretty (AbsLitPermutation xss) = "permutation" <> prettyListDoc prParens "," [ prettyList prParens "," xs | xs <- xss ]
106
107 instance (VarSymBreakingDescription x, ExpressionLike x) => VarSymBreakingDescription (AbstractLiteral x) where
108 varSymBreakingDescription (AbsLitTuple xs) = JSON.Object $ KM.fromList
109 [ ("type", JSON.String "AbsLitTuple")
110 , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription xs)
111 ]
112 varSymBreakingDescription AbsLitRecord{} = JSON.Object $ KM.fromList
113 [ ("type", JSON.String "AbsLitRecord")
114 ]
115 varSymBreakingDescription AbsLitVariant{} = JSON.Object $ KM.fromList
116 [ ("type", JSON.String "AbsLitVariant")
117 ]
118 varSymBreakingDescription (AbsLitMatrix _ xs) = JSON.Object $ KM.fromList
119 [ ("type", JSON.String "AbsLitMatrix")
120 , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription xs)
121 ]
122 varSymBreakingDescription (AbsLitSet xs) = JSON.Object $ KM.fromList
123 [ ("type", JSON.String "AbsLitSet")
124 , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription xs)
125 , ("symmetricChildren", JSON.Bool True)
126 ]
127 varSymBreakingDescription (AbsLitMSet xs) = JSON.Object $ KM.fromList
128 [ ("type", JSON.String "AbsLitMSet")
129 , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription xs)
130 , ("symmetricChildren", JSON.Bool True)
131 ]
132 varSymBreakingDescription (AbsLitFunction xs) = JSON.Object $ KM.fromList
133 [ ("type", JSON.String "AbsLitFunction")
134 , ("children", JSON.Array $ V.fromList
135 [ varSymBreakingDescription (AbsLitTuple [x,y]) | (x,y) <- xs ])
136 , ("symmetricChildren", JSON.Bool True)
137 ]
138 varSymBreakingDescription (AbsLitSequence xs) = JSON.Object $ KM.fromList
139 [ ("type", JSON.String "AbsLitSequence")
140 , ("children", JSON.Array $ V.fromList
141 [ varSymBreakingDescription (AbsLitTuple [fromInt i, x]) | (i,x) <- zip allNats xs ])
142 , ("symmetricChildren", JSON.Bool True)
143 ]
144 varSymBreakingDescription (AbsLitRelation xs) = JSON.Object $ KM.fromList
145 [ ("type", JSON.String "AbsLitRelation")
146 , ("children", JSON.Array $ V.fromList $ map (varSymBreakingDescription . AbsLitTuple) xs)
147 , ("symmetricChildren", JSON.Bool True)
148 ]
149 varSymBreakingDescription (AbsLitPartition xs) = JSON.Object $ KM.fromList
150 [ ("type", JSON.String "AbsLitPartition")
151 , ("children", JSON.Array $ V.fromList $ map (varSymBreakingDescription . AbsLitSet) xs)
152 , ("symmetricChildren", JSON.Bool True)
153 ]
154 varSymBreakingDescription (AbsLitPermutation xs) = JSON.Object $ KM.fromList
155 [ ("type", JSON.String "AbsLitPermutation")
156 , ("children", JSON.Array $ V.fromList $ map (varSymBreakingDescription . AbsLitSequence) xs)
157 , ("symmetricChildren", JSON.Bool True)
158 ]
159
160 instance (TypeOf a, Pretty a) => TypeOf (AbstractLiteral a) where
161
162 typeOf (AbsLitTuple []) = return (TypeTuple [TypeAny])
163 typeOf (AbsLitTuple xs) = TypeTuple <$> mapM typeOf xs
164
165 typeOf (AbsLitRecord xs) = TypeRecord <$> sequence [ do t <- typeOf x ; return (n,t)
166 | (n,x) <- xs ]
167
168 typeOf (AbsLitVariant Nothing _ _) = failDoc "Cannot calculate the type of variant literal."
169 typeOf (AbsLitVariant (Just t) _ _) = fmap TypeVariant $ forM t $ \ (n,d) -> do
170 dt <- typeOfDomain d
171 return (n, dt)
172
173 typeOf (AbsLitMatrix _ [] ) = return (TypeMatrix TypeAny TypeAny)
174 typeOf p@(AbsLitMatrix ind inn ) = TypeMatrix <$> typeOfDomain ind <*> (homoType (pretty p) =<< mapM typeOf inn)
175
176 typeOf (AbsLitSet [] ) = return (TypeSet TypeAny)
177 typeOf p@(AbsLitSet xs ) = TypeSet <$> (homoType (pretty p) =<< mapM typeOf xs)
178
179 typeOf (AbsLitMSet [] ) = return (TypeMSet TypeAny)
180 typeOf p@(AbsLitMSet xs ) = TypeMSet <$> (homoType (pretty p) =<< mapM typeOf xs)
181
182 typeOf (AbsLitFunction [] ) = return (TypeFunction TypeAny TypeAny)
183 typeOf p@(AbsLitFunction xs ) = TypeFunction <$> (homoType (pretty p) =<< mapM (typeOf . fst) xs)
184 <*> (homoType (pretty p) =<< mapM (typeOf . snd) xs)
185
186 typeOf (AbsLitSequence [] ) = return (TypeSequence TypeAny)
187 typeOf p@(AbsLitSequence xs ) = TypeSequence <$> (homoType (pretty p) =<< mapM typeOf xs)
188
189 typeOf (AbsLitRelation [] ) = return (TypeRelation [TypeAny])
190 typeOf p@(AbsLitRelation xss) = do
191 ty <- homoType (pretty p) =<< mapM (typeOf . AbsLitTuple) xss
192 case ty of
193 TypeTuple ts -> return (TypeRelation ts)
194 _ -> bug "expecting TypeTuple in typeOf"
195
196 typeOf (AbsLitPartition [] ) = return (TypePartition TypeAny)
197 typeOf p@(AbsLitPartition xss) = TypePartition <$> (homoType (pretty p) =<< mapM typeOf (concat xss))
198 typeOf (AbsLitPermutation [] ) = return (TypePermutation TypeAny)
199 typeOf p@(AbsLitPermutation xss) = TypePermutation <$> (homoType (pretty p) =<< mapM typeOf (concat xss))
200
201
202 normaliseAbsLit :: (Ord c, ExpressionLike c) => (c -> c) -> AbstractLiteral c -> AbstractLiteral c
203 normaliseAbsLit norm (AbsLitTuple xs ) = AbsLitTuple $ map norm xs
204 normaliseAbsLit norm (AbsLitRecord xs ) = AbsLitRecord $ map (second norm) xs
205 normaliseAbsLit norm (AbsLitVariant t n x) = AbsLitVariant t n (norm x)
206 normaliseAbsLit norm (AbsLitMatrix d xs ) = AbsLitMatrix (normaliseDomain norm d) $ map norm xs
207 normaliseAbsLit norm (AbsLitSet xs ) = AbsLitSet $ sortNub $ map norm xs
208 normaliseAbsLit norm (AbsLitMSet xs ) = AbsLitMSet $ sort $ map norm xs
209 normaliseAbsLit norm (AbsLitFunction xs ) = AbsLitFunction $ sortNub [ (norm x, norm y) | (x, y) <- xs ]
210 normaliseAbsLit norm (AbsLitSequence xs ) = AbsLitSequence $ map norm xs
211 normaliseAbsLit norm (AbsLitRelation xss) = AbsLitRelation $ sortNub $ map (map norm) xss
212 normaliseAbsLit norm (AbsLitPartition xss) = AbsLitPartition $ sortNub $ map (sortNub . map norm) xss
213 normaliseAbsLit norm (AbsLitPermutation xss) = AbsLitPermutation $ map (map norm) xss
214
215 emptyCollectionAbsLit :: AbstractLiteral c -> Bool
216 emptyCollectionAbsLit AbsLitTuple{} = False
217 emptyCollectionAbsLit AbsLitRecord{} = False
218 emptyCollectionAbsLit AbsLitVariant{} = False
219 emptyCollectionAbsLit (AbsLitMatrix _ xs) = null xs
220 emptyCollectionAbsLit (AbsLitSet xs) = null xs
221 emptyCollectionAbsLit (AbsLitMSet xs) = null xs
222 emptyCollectionAbsLit (AbsLitFunction xs) = null xs
223 emptyCollectionAbsLit (AbsLitSequence xs) = null xs
224 emptyCollectionAbsLit (AbsLitRelation xs) = null xs
225 emptyCollectionAbsLit (AbsLitPartition xs) = null xs
226 emptyCollectionAbsLit (AbsLitPermutation xs) = null xs