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 (x:_) | Just _ <- intOut "toMiniZinc" x -> MZNSet <$> mapM toMiniZinc xs
79 _ -> MZNArray Nothing <$> mapM toMiniZinc xs
80 AbsLitMSet xs -> MZNArray Nothing <$> mapM toMiniZinc xs
81 AbsLitFunction xs -> MZNArray Nothing <$> mapM (toMiniZinc . snd) xs
82 AbsLitSequence xs -> MZNArray Nothing <$> mapM toMiniZinc xs
83 AbsLitRelation xss ->
84 MZNArray Nothing <$> forM xss (\ xs ->
85 MZNArray Nothing <$> mapM toMiniZinc xs)
86 AbsLitPartition xss ->
87 MZNArray Nothing <$> forM xss (\ xs ->
88 MZNArray Nothing <$> mapM toMiniZinc xs)
89 _ -> noToMiniZinc lit
90
91 instance Pretty a => Pretty (AbstractLiteral a) where
92 pretty (AbsLitTuple xs) = (if length xs < 2 then "tuple" else prEmpty) <+> prettyList prParens "," xs
93 pretty (AbsLitRecord xs) = "record" <+> prettyList prBraces "," [ pretty n <+> "=" <++> pretty x
94 | (n,x) <- xs ]
95 pretty (AbsLitVariant _ n x) = "variant" <+> prBraces (pretty n <+> "=" <+> pretty x)
96 pretty (AbsLitMatrix _ []) = "[]"
97 pretty (AbsLitMatrix index xs) = let f i = prBrackets (i <> ";" <++> pretty index) in prettyList f "," xs
98 pretty (AbsLitSet xs ) = prettyList prBraces "," xs
99 pretty (AbsLitMSet xs ) = "mset" <> prettyList prParens "," xs
100 pretty (AbsLitFunction xs ) = "function" <> prettyListDoc prParens "," [ pretty a <++> "-->" <+> pretty b | (a,b) <- xs ]
101 pretty (AbsLitSequence xs ) = "sequence" <> prettyList prParens "," xs
102 pretty (AbsLitRelation xss) = "relation" <> prettyListDoc prParens "," [ pretty (AbsLitTuple xs) | xs <- xss ]
103 pretty (AbsLitPartition xss) = "partition" <> prettyListDoc prParens "," [ prettyList prBraces "," xs | xs <- xss ]
104 pretty (AbsLitPermutation xss) = "permutation" <> prettyListDoc prParens "," [ prettyList prParens "," xs | xs <- xss ]
105
106 instance (VarSymBreakingDescription x, ExpressionLike x) => VarSymBreakingDescription (AbstractLiteral x) where
107 varSymBreakingDescription (AbsLitTuple xs) = JSON.Object $ KM.fromList
108 [ ("type", JSON.String "AbsLitTuple")
109 , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription xs)
110 ]
111 varSymBreakingDescription AbsLitRecord{} = JSON.Object $ KM.fromList
112 [ ("type", JSON.String "AbsLitRecord")
113 ]
114 varSymBreakingDescription AbsLitVariant{} = JSON.Object $ KM.fromList
115 [ ("type", JSON.String "AbsLitVariant")
116 ]
117 varSymBreakingDescription (AbsLitMatrix _ xs) = JSON.Object $ KM.fromList
118 [ ("type", JSON.String "AbsLitMatrix")
119 , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription xs)
120 ]
121 varSymBreakingDescription (AbsLitSet xs) = JSON.Object $ KM.fromList
122 [ ("type", JSON.String "AbsLitSet")
123 , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription xs)
124 , ("symmetricChildren", JSON.Bool True)
125 ]
126 varSymBreakingDescription (AbsLitMSet xs) = JSON.Object $ KM.fromList
127 [ ("type", JSON.String "AbsLitMSet")
128 , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription xs)
129 , ("symmetricChildren", JSON.Bool True)
130 ]
131 varSymBreakingDescription (AbsLitFunction xs) = JSON.Object $ KM.fromList
132 [ ("type", JSON.String "AbsLitFunction")
133 , ("children", JSON.Array $ V.fromList
134 [ varSymBreakingDescription (AbsLitTuple [x,y]) | (x,y) <- xs ])
135 , ("symmetricChildren", JSON.Bool True)
136 ]
137 varSymBreakingDescription (AbsLitSequence xs) = JSON.Object $ KM.fromList
138 [ ("type", JSON.String "AbsLitSequence")
139 , ("children", JSON.Array $ V.fromList
140 [ varSymBreakingDescription (AbsLitTuple [fromInt i, x]) | (i,x) <- zip allNats xs ])
141 , ("symmetricChildren", JSON.Bool True)
142 ]
143 varSymBreakingDescription (AbsLitRelation xs) = JSON.Object $ KM.fromList
144 [ ("type", JSON.String "AbsLitRelation")
145 , ("children", JSON.Array $ V.fromList $ map (varSymBreakingDescription . AbsLitTuple) xs)
146 , ("symmetricChildren", JSON.Bool True)
147 ]
148 varSymBreakingDescription (AbsLitPartition xs) = JSON.Object $ KM.fromList
149 [ ("type", JSON.String "AbsLitPartition")
150 , ("children", JSON.Array $ V.fromList $ map (varSymBreakingDescription . AbsLitSet) xs)
151 , ("symmetricChildren", JSON.Bool True)
152 ]
153 varSymBreakingDescription (AbsLitPermutation xs) = JSON.Object $ KM.fromList
154 [ ("type", JSON.String "AbsLitPermutation")
155 , ("children", JSON.Array $ V.fromList $ map (varSymBreakingDescription . AbsLitSequence) xs)
156 , ("symmetricChildren", JSON.Bool True)
157 ]
158
159 instance (TypeOf a, Pretty a) => TypeOf (AbstractLiteral a) where
160
161 typeOf (AbsLitTuple []) = return (TypeTuple [TypeAny])
162 typeOf (AbsLitTuple xs) = TypeTuple <$> mapM typeOf xs
163
164 typeOf (AbsLitRecord xs) = TypeRecord <$> sequence [ do t <- typeOf x ; return (n,t)
165 | (n,x) <- xs ]
166
167 typeOf (AbsLitVariant Nothing _ _) = failDoc "Cannot calculate the type of variant literal."
168 typeOf (AbsLitVariant (Just t) _ _) = fmap TypeVariant $ forM t $ \ (n,d) -> do
169 dt <- typeOfDomain d
170 return (n, dt)
171
172 typeOf (AbsLitMatrix _ [] ) = return (TypeMatrix TypeAny TypeAny)
173 typeOf p@(AbsLitMatrix ind inn ) = TypeMatrix <$> typeOfDomain ind <*> (homoType (pretty p) =<< mapM typeOf inn)
174
175 typeOf (AbsLitSet [] ) = return (TypeSet TypeAny)
176 typeOf p@(AbsLitSet xs ) = TypeSet <$> (homoType (pretty p) =<< mapM typeOf xs)
177
178 typeOf (AbsLitMSet [] ) = return (TypeMSet TypeAny)
179 typeOf p@(AbsLitMSet xs ) = TypeMSet <$> (homoType (pretty p) =<< mapM typeOf xs)
180
181 typeOf (AbsLitFunction [] ) = return (TypeFunction TypeAny TypeAny)
182 typeOf p@(AbsLitFunction xs ) = TypeFunction <$> (homoType (pretty p) =<< mapM (typeOf . fst) xs)
183 <*> (homoType (pretty p) =<< mapM (typeOf . snd) xs)
184
185 typeOf (AbsLitSequence [] ) = return (TypeSequence TypeAny)
186 typeOf p@(AbsLitSequence xs ) = TypeSequence <$> (homoType (pretty p) =<< mapM typeOf xs)
187
188 typeOf (AbsLitRelation [] ) = return (TypeRelation [TypeAny])
189 typeOf p@(AbsLitRelation xss) = do
190 ty <- homoType (pretty p) =<< mapM (typeOf . AbsLitTuple) xss
191 case ty of
192 TypeTuple ts -> return (TypeRelation ts)
193 _ -> bug "expecting TypeTuple in typeOf"
194
195 typeOf (AbsLitPartition [] ) = return (TypePartition TypeAny)
196 typeOf p@(AbsLitPartition xss) = TypePartition <$> (homoType (pretty p) =<< mapM typeOf (concat xss))
197 typeOf (AbsLitPermutation [] ) = return (TypePermutation TypeAny)
198 typeOf p@(AbsLitPermutation xss) = TypePermutation <$> (homoType (pretty p) =<< mapM typeOf (concat xss))
199
200
201 normaliseAbsLit :: (Ord c, ExpressionLike c) => (c -> c) -> AbstractLiteral c -> AbstractLiteral c
202 normaliseAbsLit norm (AbsLitTuple xs ) = AbsLitTuple $ map norm xs
203 normaliseAbsLit norm (AbsLitRecord xs ) = AbsLitRecord $ map (second norm) xs
204 normaliseAbsLit norm (AbsLitVariant t n x) = AbsLitVariant t n (norm x)
205 normaliseAbsLit norm (AbsLitMatrix d xs ) = AbsLitMatrix (normaliseDomain norm d) $ map norm xs
206 normaliseAbsLit norm (AbsLitSet xs ) = AbsLitSet $ sortNub $ map norm xs
207 normaliseAbsLit norm (AbsLitMSet xs ) = AbsLitMSet $ sort $ map norm xs
208 normaliseAbsLit norm (AbsLitFunction xs ) = AbsLitFunction $ sortNub [ (norm x, norm y) | (x, y) <- xs ]
209 normaliseAbsLit norm (AbsLitSequence xs ) = AbsLitSequence $ map norm xs
210 normaliseAbsLit norm (AbsLitRelation xss) = AbsLitRelation $ sortNub $ map (map norm) xss
211 normaliseAbsLit norm (AbsLitPartition xss) = AbsLitPartition $ sortNub $ map (sortNub . map norm) xss
212 normaliseAbsLit norm (AbsLitPermutation xss) = AbsLitPermutation $ map (map norm) xss
213
214 emptyCollectionAbsLit :: AbstractLiteral c -> Bool
215 emptyCollectionAbsLit AbsLitTuple{} = False
216 emptyCollectionAbsLit AbsLitRecord{} = False
217 emptyCollectionAbsLit AbsLitVariant{} = False
218 emptyCollectionAbsLit (AbsLitMatrix _ xs) = null xs
219 emptyCollectionAbsLit (AbsLitSet xs) = null xs
220 emptyCollectionAbsLit (AbsLitMSet xs) = null xs
221 emptyCollectionAbsLit (AbsLitFunction xs) = null xs
222 emptyCollectionAbsLit (AbsLitSequence xs) = null xs
223 emptyCollectionAbsLit (AbsLitRelation xs) = null xs
224 emptyCollectionAbsLit (AbsLitPartition xs) = null xs
225 emptyCollectionAbsLit (AbsLitPermutation xs) = null xs