Merge pull request #665 from conjure-cp/enum-json-parsing

Improve support for parsing enums from param.json files

src/Conjure/Language/AbstractLiteral.hs

@@ -50,6 +50,7 @@ instance (SimpleJSON x, Pretty x, ExpressionLike x) => SimpleJSON (AbstractLiter
             AbsLitVariant _ nm x -> do
                 x' <- toSimpleJSON x
                 return $ JSON.Object $ KM.fromList [(fromString (renderNormal nm), x')]
+            AbsLitSequence xs -> toSimpleJSON xs
             AbsLitMatrix index xs ->
                 case index of
                     DomainInt _ ranges -> do
@@ -59,7 +60,6 @@ instance (SimpleJSON x, Pretty x, ExpressionLike x) => SimpleJSON (AbstractLiter
             AbsLitSet xs -> toSimpleJSON xs
             AbsLitMSet xs -> toSimpleJSON xs
             AbsLitFunction xs -> toSimpleJSON (AsDictionary xs)
-            AbsLitSequence xs -> toSimpleJSON xs
             AbsLitRelation xs -> toSimpleJSON xs
             AbsLitPartition xs -> toSimpleJSON xs
     fromSimpleJSON = noFromSimpleJSON "AbstractLiteral"

src/Conjure/Language/AdHoc.hs

@@ -115,7 +115,7 @@ instance SimpleJSON Integer where
                     Nothing -> noFromSimpleJSON "Integer" t text
             _ -> noFromSimpleJSON "Integer" t x
 
-data AsDictionary a b = AsDictionary [(a,b)]
+newtype AsDictionary a b = AsDictionary [(a,b)]
 
 instance (Pretty x, SimpleJSON x, SimpleJSON y) => SimpleJSON (AsDictionary x y) where
     toSimpleJSON (AsDictionary xs) = do

src/Conjure/Language/Constant.hs

@@ -103,6 +103,9 @@ instance SimpleJSON Constant where
 
     fromSimpleJSON _ (JSON.Bool b) = return (ConstantBool b)
 
+    fromSimpleJSON (TypeInt (TagEnum enum_type_name)) (JSON.String value) =
+        return (ConstantEnum (Name enum_type_name) [] (Name value))
+
     fromSimpleJSON t@TypeInt{} x@JSON.Number{} = ConstantInt TagInt <$> fromSimpleJSON t x
     fromSimpleJSON t@TypeInt{} x@JSON.String{} = ConstantInt TagInt <$> fromSimpleJSON t x
 
@@ -175,8 +178,7 @@ instance SimpleJSON Constant where
         return $ ConstantAbstract $ AbsLitFunction ys
 
     fromSimpleJSON ty@(TypeFunction fr to) value@(JSON.Array xs) = do
-        mys <- forM (V.toList xs) $ \ x ->
-                case x of
+        mys <- forM (V.toList xs) $ \case
                     JSON.Array x' ->
                         case V.toList x' of
                             [a', b'] -> do
@@ -190,6 +192,17 @@ instance SimpleJSON Constant where
             then return $ ConstantAbstract $ AbsLitFunction ys
             else noFromSimpleJSON "Constant" ty value
 
+    fromSimpleJSON (TypeSequence inner) (JSON.Object m) = do
+        ys :: [(Integer, Constant)] <- forM (KM.toList m) $ \ (toText->name, value) -> do
+            -- the name must be an integer
+            a <- fromSimpleJSON (TypeInt TagInt) (JSON.String name)
+            b <- fromSimpleJSON inner value
+            return (a, b)
+
+        let ys_sorted = sort ys
+
+        return $ ConstantAbstract $ AbsLitSequence (map snd ys_sorted)
+
     fromSimpleJSON (TypeSequence t) (JSON.Array xs) =
         ConstantAbstract . AbsLitSequence <$> mapM (fromSimpleJSON t) (V.toList xs)
 
@@ -456,7 +469,7 @@ viewConstantMatrix constant =
                 indices_as_int = [ i | ConstantInt _ i <- indices ]
             if length indices == length indices_as_int
                 then
-                    if length indices > 0
+                    if not (null indices)
                         then
                             if maximum indices_as_int - minimum indices_as_int + 1 == genericLength indices
                                 then return (DomainInt TagInt [RangeBounded (fromInt (minimum indices_as_int)) (fromInt (maximum indices_as_int))], values)
@@ -494,6 +507,7 @@ viewConstantFunction constant = do
 
 viewConstantSequence :: MonadFailDoc m => Constant -> m [Constant]
 viewConstantSequence (ConstantAbstract (AbsLitSequence xs)) = return xs
+viewConstantSequence (ConstantAbstract (AbsLitMatrix _ xs)) = return xs
 viewConstantSequence (TypedConstant c _) = viewConstantSequence c
 viewConstantSequence constant = failDoc ("Expecting a sequence, but got:" <++> pretty constant)
 

src/Conjure/Language/Definition.hs

@@ -105,20 +105,29 @@ fromSimpleJSONModel essence json =
     case json of
         JSON.Object inners -> do
             stmts <- forM (KM.toList inners) $ \ (toText->name, valueJSON) -> do
-                -- traceM $ show $ "name    " <+> pretty name
                 let mdomain = [ dom
                               | Declaration (FindOrGiven Given (Name nm) dom) <- mStatements essence
                               , nm == name
                               ]
-                -- traceM $ show $ "mdomain " <+> vcat (map pretty mdomain)
-                case mdomain of
-                    [domain] -> do
-                        -- traceM $ show $ "domain  " <+> pretty domain
+                let enums = [ nm
+                            | Name nm <- essence |> mInfo |> miEnumGivens
+                            , nm == name
+                            ]
+                case (mdomain, enums) of
+                    ([domain], _) -> do
                         typ <- typeOfDomain domain
-                        -- traceM $ show $ "typ     " <+> pretty typ
                         value <- fromSimpleJSON typ valueJSON
-                        -- traceM $ show $ "value   " <+> pretty value
                         return $ Just $ Declaration (Letting (Name name) value)
+                    (_, [enum]) -> do
+                        case valueJSON of
+                            JSON.Array v -> do
+                                    let vals = [ case str of
+                                                    JSON.String t -> Name t
+                                                    _ -> bug ("fromSimpleJSONModel not name: " <+> pretty (show str))
+                                               | str <- V.toList v
+                                               ]
+                                    return $ Just $ Declaration (LettingDomainDefnEnum (Name enum) vals)
+                            _ -> bug "fromSimpleJSONModel"
                     _ -> do
                         logWarn $ "Ignoring" <+> pretty name <+> "from the JSON file."
                         return Nothing

src/Conjure/Language/Expression.hs

@@ -164,6 +164,9 @@ instance SimpleJSON Declaration where
             Letting nm x -> do
                 x' <- toSimpleJSON x
                 return $ JSON.Object $ KM.fromList [(fromString (renderNormal nm), x')]
+            LettingDomainDefnEnum nm xs -> do
+                let xs' = map (fromString . renderNormal) xs
+                return $ JSON.Object $ KM.fromList [(fromString (renderNormal nm), JSON.Array (V.fromList xs'))]
             _ -> noToSimpleJSON d
     fromSimpleJSON = noFromSimpleJSON "Declaration"
 

src/Conjure/Language/Expression/Op/TwoBars.hs

@@ -29,6 +29,7 @@ instance (TypeOf x, Pretty x, Domain () x :< x) => TypeOf (OpTwoBars x) where
                 case ty of
                     TypeInt _       -> return ()
                     TypeList{}      -> return ()
+                    TypeMatrix{}    -> return ()
                     TypeSet{}       -> return ()
                     TypeMSet{}      -> return ()
                     TypeFunction{}  -> return ()

src/Conjure/Process/Enums.hs

@@ -194,6 +194,12 @@ removeEnumsFromParam model param = do
             = return (fromIntWithTag i (TagEnum ename))
         onX p = return p
 
+        onC :: Monad m => Constant -> m Constant
+        onC (ConstantEnum _ _ nm)
+            | Just (Name ename, i) <- M.lookup nm nameToIntMapping
+            = return (fromIntWithTag i (TagEnum ename))
+        onC p = return p
+
         onD :: MonadFailDoc m => Domain () Expression -> m (Domain () Expression)
         onD (DomainEnum nm@(Name nmText) (Just ranges) _)
             | Just _ <- M.lookup nm enumDomainNames
@@ -207,7 +213,7 @@ removeEnumsFromParam model param = do
         onD p = return p
 
     let param' = param { mStatements = catMaybes statements' }
-    let f = transformBiM onD >=> transformBiM onX
+    let f = transformBiM onD >=> transformBiM onX >=> transformBiM onC
     (,) <$> f model <*> f param'
 
 

src/Conjure/Process/ValidateConstantForDomain.hs

@@ -4,41 +4,10 @@ module Conjure.Process.ValidateConstantForDomain ( validateConstantForDomain ) w
 
 import Conjure.Prelude
 import Conjure.Language.Constant
-    ( viewConstantBool,
-      viewConstantFunction,
-      viewConstantIntWithTag,
-      viewConstantMSet,
-      viewConstantMatrix,
-      viewConstantPartition,
-      viewConstantRecord,
-      viewConstantRelation,
-      viewConstantSequence,
-      viewConstantSet,
-      viewConstantTuple,
-      viewConstantVariant,
-      Constant(ConstantEnum, TypedConstant, ConstantInt, ConstantBool) )
 import Conjure.Language.Definition
-    ( Name,
-      NameGen, forgetRepr )
 import Conjure.Language.Domain
-    ( Domain(DomainBool, DomainUnnamed, DomainEnum, DomainPartition,
-             DomainTuple, DomainRecord, DomainVariant, DomainMatrix, DomainInt,
-             DomainSet, DomainMSet, DomainFunction, DomainSequence,
-             DomainRelation),
-      Range(RangeBounded, RangeOpen, RangeSingle, RangeLowerBounded,
-            RangeUpperBounded),
-      BinaryRelationAttrs(BinaryRelationAttrs),
-      RelationAttr(RelationAttr),
-      OccurAttr(OccurAttr_MinMaxOccur, OccurAttr_None,
-                OccurAttr_MinOccur, OccurAttr_MaxOccur),
-      MSetAttr(MSetAttr),
-      SizeAttr(SizeAttr_MinMaxSize, SizeAttr_None, SizeAttr_Size,
-               SizeAttr_MinSize, SizeAttr_MaxSize),
-      SetAttr(SetAttr),
-      binRelToAttrName, SequenceAttr (SequenceAttr), JectivityAttr (JectivityAttr_Surjective, JectivityAttr_Bijective) )
+import Conjure.Language.Type
 import Conjure.Language.Pretty 
-import Conjure.Language.Type ( TypeCheckerMode )
-import Conjure.Language.Expression
 import Conjure.Language.Instantiate ( instantiateExpression )
 import Conjure.Process.AttributeAsConstraints ( mkAttributeToConstraint )
 import Conjure.Process.Enumerate ( EnumerateDomain, enumerateDomain )
@@ -64,6 +33,9 @@ validateConstantForDomain _ (viewConstantBool -> Just _) DomainBool{} = return (
 
 validateConstantForDomain _ _ (DomainInt _ []) = return ()              -- no restrictions
 
+-- enums, always ok
+validateConstantForDomain _ (ConstantEnum (Name ty1) _ _) (DomainInt (TagEnum ty2) _) | ty1 == ty2 = return ()
+
 validateConstantForDomain name c@(viewConstantIntWithTag -> Just (cTag, i)) d@(DomainInt dTag rs) | cTag == dTag =
     let
         intInRange RangeOpen                                          = True