diff --git a/flake.nix b/flake.nix index 4da3cb91f..43dc0e957 100644 --- a/flake.nix +++ b/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. diff --git a/primer/gen/Primer/Gen/Core/Raw.hs b/primer/gen/Primer/Gen/Core/Raw.hs index 3137cc075..e54adcfb1 100644 --- a/primer/gen/Primer/Gen/Core/Raw.hs +++ b/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 = diff --git a/primer/gen/Primer/Gen/Core/Typed.hs b/primer/gen/Primer/Gen/Core/Typed.hs index 57e75b18c..c9df7ab7e 100644 --- a/primer/gen/Primer/Gen/Core/Typed.hs +++ b/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 diff --git a/primer/primer.cabal b/primer/primer.cabal index 06dd2fddd..610df7a7b 100644 --- a/primer/primer.cabal +++ b/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 diff --git a/primer/src/Primer/Builtins.hs b/primer/src/Primer/Builtins.hs index 8c1f2d06b..bd4578634 100644 --- a/primer/src/Primer/Builtins.hs +++ b/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 diff --git a/primer/src/Primer/Core/Meta.hs b/primer/src/Primer/Core/Meta.hs index ced09b4e4..eec1510fe 100644 --- a/primer/src/Primer/Core/Meta.hs +++ b/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) diff --git a/primer/src/Primer/Module.hs b/primer/src/Primer/Module.hs index ee11fd19a..8548230ac 100644 --- a/primer/src/Primer/Module.hs +++ b/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 } diff --git a/primer/src/Primer/Pretty.hs b/primer/src/Primer/Pretty.hs index 7ffdd2e32..53ec292b2 100644 --- a/primer/src/Primer/Pretty.hs +++ b/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 " diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index e12ace782..5865cddc5 100644 --- a/primer/src/Primer/Primitives.hs +++ b/primer/src/Primer/Primitives.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -6,6 +7,7 @@ module Primer.Primitives ( allPrimTypeDefs, tInt, tChar, + tGlossProg, primitive, primitiveGVar, primConName, @@ -20,25 +22,46 @@ import Foreword import Control.Monad.Fresh (MonadFresh) import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.ByteString.Base64 qualified as B64 import Data.Data (Data) import Data.Map qualified as M +import Diagrams (fillColor) +import Diagrams.Backend.Rasterific ( + GifLooping (LoopingForever), + defaultPaletteOptions, + rasterGif, + ) +import Diagrams.Prelude ( + V2 (..), + circle, + deg, + mkSizeSpec, + rect, + sRGB24, + (@@), + ) +import Diagrams.Prelude qualified as D import Numeric.Natural (Natural) import Primer.Builtins ( + GlossPictureDefHS (..), cSucc, cZero, tBool, + tGlossPicture, tMaybe, tNat, + toGlossPictureDefHS, ) import Primer.Builtins.DSL (boolAnn, maybeAnn, nat) import Primer.Core ( Expr, - Expr' (Con, PrimCon), + Expr' (..), GVarName, GlobalName, ID, ModuleName, - PrimCon (PrimChar, PrimInt), + PrimCon (PrimChar, PrimGlossProg, PrimInt), + TmVarRef (LocalVarRef), TyConName, Type' (..), mkSimpleModuleName, @@ -48,6 +71,7 @@ import Primer.Core.DSL ( ann, char, int, + prim, tcon, ) import Primer.Core.Utils (generateIDs) @@ -74,6 +98,7 @@ primConName :: PrimCon -> TyConName primConName = \case PrimChar _ -> tChar PrimInt _ -> tInt + PrimGlossProg _ -> tGlossProg primitive :: Name -> GlobalName k primitive = qualifyName primitiveModuleName @@ -84,6 +109,9 @@ tChar = primitive "Char" tInt :: TyConName tInt = primitive "Int" +tGlossProg :: TyConName +tGlossProg = primitive "Gloss" + -- | Construct a reference to a primitive definition. primitiveGVar :: PrimDef -> GVarName primitiveGVar = primitive . primDefName @@ -107,6 +135,13 @@ allPrimTypeDefs = , primTypeDefNameHints = ["i", "j", "k", "m", "n"] } ) + , let name = tGlossProg + in ( name + , PrimTypeDef + { primTypeDefParameters = [] + , primTypeDefNameHints = [] + } + ) ] where -- This ensures that when we modify the constructors of `PrimCon` (i.e. we add/remove primitive types), @@ -114,6 +149,7 @@ allPrimTypeDefs = _ = \case PrimChar _ -> () PrimInt _ -> () + PrimGlossProg _ -> () primDefName :: PrimDef -> Name primDefName = \case @@ -137,6 +173,7 @@ primDefName = \case IntNeq -> "Int.≠" IntToNat -> "Int.toNat" IntFromNat -> "Int.fromNat" + PlayGloss -> "play" PrimConst -> "const" primDefType :: PrimDef -> Type' () () @@ -164,12 +201,20 @@ primFunTypes = \case IntNeq -> ([c tInt, c tInt], c tBool) IntToNat -> ([c tInt], c tMaybe `a` c tNat) IntFromNat -> ([c tNat], c tInt) + PlayGloss -> + ( + [ c tInt + , c tInt `f` c tGlossPicture + ] + , c tGlossProg + ) -- Arbitrarily limited to `Int` and `Bool` since we our system doesn't allow polymorphic primitives. -- Note that this primitive is only for testing anyway. PrimConst -> ([c tBool, c tNat], c tBool) where c = TCon () a = TApp () + f = TFun () primFunDef :: PrimDef -> [Expr' () () ()] -> Either PrimFunError (forall m. MonadFresh ID m => m Expr) primFunDef def args = case def of @@ -276,6 +321,60 @@ primFunDef def args = case def of [exprToNat -> Just n] -> Right $ int $ fromIntegral n _ -> err + PlayGloss -> case args of + -- TODO `p` is an expression of type `GlossPicture` with one free variable (with its name taken from `t`) + -- for now we just ignore `t` and hope that it is unused, i.e. that `p` is closed + -- until then, we are using arbitrary time values in the list + -- TODO all times are in hundredths of a second due to GIF spec - this may not be great + -- TODO we have lossy `fromInteger` conversions + [PrimCon () (PrimInt duration), Lam () time pic0] -> + case traverse picAt [0 .. (duration * 100) `div` frameLength] of + Nothing -> err + Just pics -> + Right + $ prim + . PrimGlossProg + . either + -- this case really shouldn't be able to happen, unless `diagrams-rasterific` is broken + -- in fact, the default behaviour (`animatedGif`) is just to write the error to `stdout` + -- we only see it because we have to use the lower-level `rasterGif` for unrelated reasons + -- (wanting to get the `Bytestring` without dumping it to a file) + mempty + (decodeUtf8 . B64.encode . toS) + $ rasterGif + (mkSizeSpec $ Just . fromInteger @Double <$> V2 width height) + gifLooping + defaultPaletteOptions + $ map + ( (,fromInteger frameLength) + -- TODO we need this for sizes to appear consistent across frames + -- I'm a bit surprised that `diagrams-rasterific` doesn't normalise for us instead + -- note that this does become irrelevant if the drawn image is larger than declared + -- maybe we should just scale or something instead? + -- might be best to avoid hardcoding a canvas width and height, and instead base it on the largest frame + -- but then we can't easily tell students that rendering is taking ages because their GIF is too big + . (<> (rect (fromInteger width) (fromInteger height) & fillColor D.white)) + ) + pics + where + picAt t = + exprToPicture $ subst time (PrimCon () (PrimInt t)) pic0 + -- TODO this isn't enough - we might have expressions which can't be reduced until after substitution + -- TODO surely there's already something we can reuse here? + -- TODO more cases? and why can't I use `transform`? + subst t a = \case + Var () (LocalVarRef t') | t' == t -> a + Con () c es -> Con () c $ map (subst t a) es + e -> e + -- stuff that's hardcoded, for now at least, for the sake of keeping the student-facing API simple + -- TODO add more values here - my example in editor is still too complex (EDIT: no longer true?) + gifLooping = LoopingForever + -- this is in hundredths of a second, as per the GIF spec + -- we keep the frame rate low for now to avoid serialising huge GIFs + frameLength = 10 + width = 160 + height = 90 + _ -> err PrimConst -> case args of [x, _] -> Right $ generateIDs x `ann` tcon tBool @@ -285,4 +384,24 @@ primFunDef def args = case def of Con _ c [] | c == cZero -> Just 0 Con _ c [x] | c == cSucc -> succ <$> exprToNat x _ -> Nothing + -- TODO there are a lot of lossy `fromInteger` conversions going on here + -- will be fine when we just have a primitive `Double` instead of using `Integer` + exprToPicture e = + toGlossPictureDefHS e >>= fix \f -> \case + GlossPictureDefHSCircle r -> + -- TODO line colours as well as fill colours? + pure + $ if r == 0 + then mempty -- TODO this crashes otherwise - are there similar issues elsewhere? + else circle (fromInteger r) & fillColor D.black + GlossPictureDefHSRect w h -> pure $ rect (fromInteger w) (fromInteger h) & fillColor D.black + GlossPictureDefHSColour r g b p -> f p <&> fillColor (sRGB24 (fromInteger r) (fromInteger g) (fromInteger b)) + GlossPictureDefHSRotate a p -> f p <&> D.rotate (fromInteger a @@ deg) + GlossPictureDefHSTranslate x y p -> f p <&> D.translate (V2 (fromInteger x) (fromInteger y)) + GlossPictureDefHSCompoundPicture ps -> foldMap' f ps + -- exprToPicture e = + -- toGlossPictureDefHS e <&> \case + -- GlossPictureDefHSCompoundPicture ps -> circle 30 & fillColor D.green + -- _ -> circle 30 & fillColor D.red + -- exprToPicture e = Just $ circle 30 & fillColor D.green err = Left $ PrimFunError def args diff --git a/primer/src/Primer/Primitives/PrimDef.hs b/primer/src/Primer/Primitives/PrimDef.hs index f23bbaf29..f17cdfa45 100644 --- a/primer/src/Primer/Primitives/PrimDef.hs +++ b/primer/src/Primer/Primitives/PrimDef.hs @@ -34,6 +34,7 @@ data PrimDef | IntNeq | IntToNat | IntFromNat + | PlayGloss | -- | Only for testing PrimConst deriving stock (Eq, Show, Read, Enum, Bounded, Data, Generic)