Animations

flake.nix

@@ -415,6 +415,8 @@
                     # https://github.com/input-output-hk/haskell.nix/issues/1242
                     packages.mtl-compat.writeHieFiles = false;
                     packages.bytestring-builder.writeHieFiles = false;
+                    packages.fail.writeHieFiles = false;
+                    packages.diagrams.writeHieFiles = false;
                   }
                   {
                     #TODO This shouldn't be necessary - see the commented-out `build-tool-depends` in primer.cabal.

primer-service/test/outputs/OpenAPI/openapi.json

@@ -628,6 +628,24 @@
                             "contents"
                         ],
                         "type": "object"
+                    },
+                    {
+                        "properties": {
+                            "contents": {
+                                "type": "string"
+                            },
+                            "tag": {
+                                "enum": [
+                                    "PrimAnimation"
+                                ],
+                                "type": "string"
+                            }
+                        },
+                        "required": [
+                            "tag",
+                            "contents"
+                        ],
+                        "type": "object"
                     }
                 ]
             },

primer/gen/Primer/Gen/Core/Raw.hs

@@ -168,6 +168,7 @@ genPrimCon =
     _ = \case
       PrimChar _ -> ()
       PrimInt _ -> ()
+      PrimAnimation _ -> ()
 
 genType :: ExprGen Type
 genType =

primer/gen/Primer/Gen/Core/Typed.hs

@@ -490,7 +490,7 @@ genChk ty = do
             brs0 <- Gen.list (Range.linear 0 5) $ do
               p <- pg
               (p,) . CaseBranch (PatPrim p) [] <$> genChk ty
-            let brs = nubSortOn ((\case PrimInt n -> Left n; PrimChar c -> Right c) . fst) brs0
+            let brs = nubSortOn ((\case PrimInt n -> Left (Left n); PrimChar c -> Left (Right c); PrimAnimation b -> Right b) . fst) brs0
             fb <- genChk ty
             pure $ Case () e (snd <$> brs) (CaseFallback fb)
 
@@ -679,6 +679,7 @@ genPrimCon = catMaybes <$> sequence [whenInScope PrimChar 'a' genChar, whenInSco
     _ = \case
       PrimChar _ -> ()
       PrimInt _ -> ()
+      PrimAnimation _ -> ()
 
 -- We bias the distribution towards a small set, to make it more likely we
 -- generate name clashes on occasion

primer/primer.cabal

@@ -109,11 +109,15 @@ library
     , aeson                        >=2.0     && <2.2
     , assoc                        ^>=1.1
     , base                         >=4.12    && <4.19
+    , base64-bytestring            ^>=1.2.1
     , containers                   >=0.6.0.1 && <0.7.0
     , deriving-aeson               >=0.2     && <0.3.0
+    , diagrams-lib                 ^>=1.4.6
+    , diagrams-rasterific          ^>=1.4.2
     , exceptions                   >=0.10.4  && <0.11.0
     , extra                        >=1.7.10  && <1.8.0
     , generic-optics               >=2.0     && <2.3.0
+    , JuicyPixels                  ^>=3.3.8
     , list-t                       >=1.0     && <1.1.0
     , logging-effect               ^>=1.4
     , mmorph                       ^>=1.2.0
@@ -267,6 +271,7 @@ test-suite primer-test
       , aeson
       , aeson-pretty                 ^>=0.8.9
       , base
+      , base64-bytestring
       , bytestring
       , containers
       , extra

primer/src/Primer/Core/Meta.hs

@@ -195,6 +195,8 @@ instance HasMetadata (Meta a) where
 data PrimCon
   = PrimChar Char
   | PrimInt Integer
+  | -- | Contains a base-64 encoding of an animated GIF.
+    PrimAnimation Text
   deriving stock (Eq, Show, Read, Data, Generic)
   deriving (FromJSON, ToJSON) via PrimerJSON PrimCon
   deriving anyclass (NFData)

primer/src/Primer/Module.hs

@@ -62,7 +62,7 @@ import Primer.JSON (
   ToJSON,
  )
 import Primer.Name (Name)
-import Primer.Primitives (allPrimTypeDefs, primDefName, primitiveModuleName)
+import Primer.Primitives (allPrimTypeDefs, pictureDef, primDefName, primitiveModuleName, tPicture)
 import Primer.TypeDef (TypeDef (..), TypeDefMap, forgetTypeDefMetadata, generateTypeDefIDs)
 
 data Module = Module
@@ -133,10 +133,11 @@ nextModuleID m =
 primitiveModule :: MonadFresh ID m => m Module
 primitiveModule = do
   allPrimTypeDefs' <- traverse (generateTypeDefIDs . TypeDefPrim) allPrimTypeDefs
+  pictureDef' <- generateTypeDefIDs $ TypeDefAST pictureDef
   pure
     Module
       { moduleName = primitiveModuleName
-      , moduleTypes = M.mapKeys baseName allPrimTypeDefs'
+      , moduleTypes = M.mapKeys baseName allPrimTypeDefs' <> M.fromList [(baseName tPicture, pictureDef')]
       , moduleDefs = M.fromList $ [(primDefName def, DefPrim def) | def <- enumerate]
       }
 

primer/src/Primer/Pretty.hs

@@ -185,6 +185,7 @@ prettyExpr opts = \case
     prim = \case
       PrimChar c -> "Char" <+> pretty @Text (show c)
       PrimInt n -> "Int" <+> pretty @Text (show n)
+      PrimAnimation n -> pretty @Text (show n)
     typeann e t = brac Round Yellow (pE e) <+> col Yellow "::" <> line <> brac Round Yellow (pT t)
 
 -- When grouped: " x "