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