WIP

Signed-off-by: George Thomas <[email protected]>

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/gen/Primer/Gen/Core/Raw.hs

@@ -165,6 +165,8 @@ genPrimCon =
     _ = \case
       PrimChar _ -> ()
       PrimInt _ -> ()
+      -- TODO actually update the above?
+      PrimGlossProg _ -> ()
 
 genType :: ExprGen Type
 genType =

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

@@ -487,7 +487,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); PrimGlossProg b -> Right b) . fst) brs0
             fb <- genChk ty
             pure $ Case () e (snd <$> brs) (CaseFallback fb)
 
@@ -676,6 +676,8 @@ genPrimCon = catMaybes <$> sequence [whenInScope PrimChar 'a' genChar, whenInSco
     _ = \case
       PrimChar _ -> ()
       PrimInt _ -> ()
+      -- TODO actually update generator
+      PrimGlossProg _ -> ()
 
 -- We bias the distribution towards a small set, to make it more likely we
 -- generate name clashes on occasion

primer/primer.cabal

@@ -109,8 +109,11 @@ 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

primer/src/Primer/Builtins.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ViewPatterns #-}
+
 -- | This module defines some builtin types that are used to seed initial programs.
 --   The definitions here are no different than ones than a student can create, except
 --   for the fact that some of the primitive functions (see "Primer.Primitives")
@@ -27,8 +29,16 @@ module Primer.Builtins (
   cRight,
   eitherDef,
   builtinModuleName,
+  tGlossPicture,
+  cCircle,
+  glossPictureDef,
+  GlossPictureDefHS (..),
+  toGlossPictureDefHS,
 ) where
 
+import Foreword
+
+import Primer.Core (Expr' (..), PrimCon (..))
 import Primer.Core.Meta (
   GlobalName,
   ModuleName,
@@ -50,6 +60,22 @@ builtinModuleName = mkSimpleModuleName "Builtins"
 builtin :: Name -> GlobalName k
 builtin = qualifyName builtinModuleName
 
+tGlossPicture :: TyConName
+tGlossPicture = builtin "Picture"
+
+cCircle :: ValConName
+cCircle = builtin "Circle"
+cRect :: ValConName
+cRect = builtin "Rectangle"
+cColour :: ValConName
+cColour = builtin "Colour"
+cRotate :: ValConName
+cRotate = builtin "Rotate"
+cTranslate :: ValConName
+cTranslate = builtin "Translate"
+cCompoundPicture :: ValConName
+cCompoundPicture = builtin "Compound"
+
 tBool :: TyConName
 tBool = builtin "Bool"
 cTrue, cFalse :: ValConName
@@ -151,3 +177,80 @@ eitherDef =
     , astTypeDefConstructors = [ValCon cLeft [TVar () "a"], ValCon cRight [TVar () "b"]]
     , astTypeDefNameHints = []
     }
+
+-- TODO more constructors?
+-- useful (I think? see how it pans out)
+-- in some cases, gives us handy compile-time exhaustiveness checks
+-- makes it easier to get things right (?)
+-- etc.
+-- TODO do similar for all defs in this module? i.e. centralise `exprToNat` etc.?
+-- TODO naming
+-- TODO use `Double` here instead?
+-- NB when adding a constructor here, we should add it to the other definitions nearby
+data GlossPictureDefHS
+  = GlossPictureDefHSCircle Integer
+  | GlossPictureDefHSRect Integer Integer
+  | GlossPictureDefHSColour Integer Integer Integer GlossPictureDefHS
+  | GlossPictureDefHSRotate Integer GlossPictureDefHS
+  | GlossPictureDefHSTranslate Integer Integer GlossPictureDefHS
+  | GlossPictureDefHSCompoundPicture [GlossPictureDefHS] -- note that pictures earlier in list appear on top
+toGlossPictureDefHS :: Expr' a b c -> Maybe GlossPictureDefHS
+toGlossPictureDefHS = \case
+  Con _ c [PrimCon _ (PrimInt r)]
+    | c == cCircle ->
+        Just $ GlossPictureDefHSCircle r
+  Con _ c [PrimCon _ (PrimInt w), PrimCon _ (PrimInt h)]
+    | c == cRect ->
+        Just $ GlossPictureDefHSRect w h
+  Con _ c [PrimCon _ (PrimInt r), PrimCon _ (PrimInt g), PrimCon _ (PrimInt b), toGlossPictureDefHS -> Just p]
+    | c == cColour ->
+        Just $ GlossPictureDefHSColour r g b p
+  Con _ c [PrimCon _ (PrimInt a), toGlossPictureDefHS -> Just p]
+    | c == cRotate ->
+        Just $ GlossPictureDefHSRotate a p
+  Con _ c [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y), toGlossPictureDefHS -> Just p]
+    | c == cTranslate ->
+        Just $ GlossPictureDefHSTranslate x y p
+  -- Con _ c (traverse toGlossPictureDefHS -> Just ps)
+  --   | c == cCompoundPicture ->
+  --       Just $ GlossPictureDefHSCompoundPicture ps
+  Con _ c [exprToList -> Just (traverse toGlossPictureDefHS -> Just ps)]
+    | c == cCompoundPicture ->
+        Just $ GlossPictureDefHSCompoundPicture ps
+  _ -> Nothing
+
+-- TODO unused for now, but might be useful for testing
+-- fromGlossPictureDefHS :: GlossPictureDefHS -> Expr' a b c
+-- fromGlossPictureDefHS = \case
+--   GlossPictureDefHSCircle r -> undefined
+--   GlossPictureDefHSRect w h -> undefined
+--   GlossPictureDefHSColour r g b p -> undefined
+--   GlossPictureDefHSRotate a p -> undefined
+--   GlossPictureDefHSTranslate x y p -> undefined
+--   GlossPictureDefHSCompoundPicture ps -> undefined
+
+glossPictureDef :: ASTTypeDef () ()
+glossPictureDef =
+  ASTTypeDef
+    { astTypeDefParameters = []
+    , astTypeDefConstructors =
+        [ ValCon cCircle [TCon () tInt]
+        , ValCon cRect [TCon () tInt, TCon () tInt]
+        , ValCon cColour [TCon () tInt, TCon () tInt, TCon () tInt, TCon () tGlossPicture]
+        , ValCon cRotate [TCon () tInt, TCon () tGlossPicture]
+        , ValCon cTranslate [TCon () tInt, TCon () tInt, TCon () tGlossPicture]
+        , ValCon cCompoundPicture [TApp () (TCon () tList) (TCon () tGlossPicture)]
+        ]
+    , astTypeDefNameHints = []
+    }
+
+-- TODO can't import due to cyclic modules
+tInt :: TyConName
+tInt = qualifyName (mkSimpleModuleName "Primitives") "Int"
+
+-- TODO put this somewhere more sensible
+exprToList :: Expr' a b c -> Maybe [Expr' a b c]
+exprToList = \case
+  Con _ c [] | c == cNil -> Just []
+  Con _ c [x, exprToList -> Just xs] | c == cCons -> Just $ x : xs
+  _ -> Nothing

primer/src/Primer/Core/Meta.hs

@@ -195,6 +195,9 @@ instance HasMetadata (Meta a) where
 data PrimCon
   = PrimChar Char
   | PrimInt Integer
+  | -- | Contains a base-64 encoding of an animated GIF.
+    -- TODO rename this and others ("Animation"?) - no longer using Gloss
+    PrimGlossProg Text
   deriving stock (Eq, Show, Read, Data, Generic)
   deriving (FromJSON, ToJSON) via PrimerJSON PrimCon
   deriving anyclass (NFData)

primer/src/Primer/Module.hs

@@ -28,12 +28,14 @@ import Primer.Builtins (
   boolDef,
   builtinModuleName,
   eitherDef,
+  glossPictureDef,
   listDef,
   maybeDef,
   natDef,
   pairDef,
   tBool,
   tEither,
+  tGlossPicture,
   tList,
   tMaybe,
   tNat,
@@ -148,6 +150,7 @@ builtinModule = do
   maybeDef' <- generateTypeDefIDs $ TypeDefAST maybeDef
   pairDef' <- generateTypeDefIDs $ TypeDefAST pairDef
   eitherDef' <- generateTypeDefIDs $ TypeDefAST eitherDef
+  glossPictureDef' <- generateTypeDefIDs $ TypeDefAST glossPictureDef
   pure
     $ Module
       { moduleName = builtinModuleName
@@ -159,6 +162,7 @@ builtinModule = do
             , (baseName tMaybe, maybeDef')
             , (baseName tPair, pairDef')
             , (baseName tEither, eitherDef')
+            , (baseName tGlossPicture, glossPictureDef')
             ]
       , moduleDefs = mempty
       }

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)
+      PrimGlossProg n -> pretty @Text $ show n -- TODO
     typeann e t = brac Round Yellow (pE e) <+> col Yellow "::" <> line <> brac Round Yellow (pT t)
 
 -- When grouped: " x "