Get rid of oeis2 and polysemy-plugin dependencies to allow compiling with WASM (#449)

Author: byorgey

.gitignore

@@ -82,3 +82,5 @@ tmp/
 
 *.pygtex
 *.pygstyle
+
+*/_minted/*

cabal.project

@@ -0,0 +1,6 @@
+packages: *.cabal
+
+source-repository-package
+    type: git
+    location: https://github.com/disco-lang/polysemy
+    tag: db923b90c88374c8de4e597136f0ec3154533677

disco.cabal

@@ -397,7 +397,7 @@ common common
 
 library
   import:              common
-  ghc-options:         -flate-specialise -fspecialise-aggressively -fplugin=Polysemy.Plugin
+  ghc-options:         -flate-specialise -fspecialise-aggressively
   default-extensions:  DataKinds
                        DeriveGeneric
                        FlexibleContexts
@@ -487,7 +487,6 @@ library
                        -- Need the Alpha and Subst instances for
                        -- NonEmpty from unbound-generics 0.4.4
                        polysemy >= 1.6.0.0 && < 1.10,
-                       polysemy-plugin >= 0.4 && < 0.5,
                        reflection >= 2.1.7 && < 2.2,
                        random >= 1.2.1.1 && < 1.4,
                        constraints >= 0.13.4 && < 0.15,
@@ -503,7 +502,6 @@ library
                        splitmix >= 0.1 && < 0.2,
                        fgl >= 5.5 && < 5.9,
                        optparse-applicative >= 0.12 && < 0.20,
-                       oeis2 >= 1.0.9 && < 1.1,
                        algebraic-graphs >= 0.5 && < 0.8,
                        pretty-show >= 1.10 && < 1.11,
                        boxes >= 0.1.5 && < 0.2,
@@ -530,7 +528,6 @@ executable disco
                        unbound-generics >= 0.3 && < 0.5,
                        lens >= 4.14 && < 5.4,
                        optparse-applicative >= 0.12 && < 0.20,
-                       oeis2 >= 1.0.9 && < 1.1
 
   default-language:    Haskell2010
 

example/catalan.disco

@@ -1,5 +1,4 @@
 import list
-import oeis
 
 -- The type of binary tree shapes: empty tree, or a pair of subtrees.
 type BT = Unit + BT*BT
@@ -13,7 +12,3 @@ treesOfSize(k+1) =
 -- Compute first few Catalan numbers by brute force.
 catalan1 : List(N)
 catalan1 = each(\k. length(treesOfSize(k)), [0..4])
-
--- Extend the sequence via the OEIS.
-catalan : List(N)
-catalan = extendSequence(catalan1)

src/Disco/AST/Core.hs

@@ -218,10 +218,6 @@ data Op
     OCrash
   | -- | No-op/identity function
     OId
-  | -- | Lookup OEIS sequence
-    OLookupSeq
-  | -- | Extend a List via OEIS
-    OExtendSeq
   | -- | Not the Boolean `And`, but instead a propositional BOp
     -- | Should only be seen and used with Props.
     OAnd
@@ -298,7 +294,7 @@ instance Pretty Core where
 toTuple :: [Core] -> Core
 toTuple = foldr CPair CUnit
 
-prettyTestVars :: Members '[Reader PA, LFresh] r => [(String, Type, Name Core)] -> Sem r (Doc ann)
+prettyTestVars :: Members '[Reader PA, LFresh] r => [(String, Type, Name Core)] -> Sem r Doc
 prettyTestVars = brackets . intercalate "," . map prettyTestVar
  where
   prettyTestVar (s, ty, n) = parens (intercalate "," [text s, pretty ty, pretty n])
@@ -384,8 +380,6 @@ opToStr = \case
   OMatchErr -> "matchErr"
   OCrash -> "crash"
   OId -> "id"
-  OLookupSeq -> "lookupSeq"
-  OExtendSeq -> "extendSeq"
   OForall {} -> "∀"
   OExists {} -> "∃"
   OAnd -> "and"

src/Disco/AST/Surface.hs

@@ -234,7 +234,7 @@ instance Pretty (Name a, Bind [Pattern] Term) where
     pretty x <> hcat (map prettyPatternP ps) <+> text "=" <+> setPA initPA (pretty t)
 
 -- | Pretty-print a type declaration.
-prettyTyDecl :: Members '[Reader PA, LFresh] r => Name t -> Type -> Sem r (Doc ann)
+prettyTyDecl :: Members '[Reader PA, LFresh] r => Name t -> Type -> Sem r Doc
 prettyTyDecl x ty = hsep [pretty x, text ":", pretty ty]
 
 ------------------------------------------------------------
@@ -525,7 +525,7 @@ pattern PNonlinear p x <- PNonlinear_ (unembed -> p) x
 -- term (e.g. via the :doc REPL command).
 
 -- | Pretty-print a term with guaranteed parentheses.
-prettyTermP :: Members '[LFresh, Reader PA] r => Term -> Sem r (Doc ann)
+prettyTermP :: Members '[LFresh, Reader PA] r => Term -> Sem r Doc
 prettyTermP t@TTup {} = setPA initPA $ pretty t
 -- prettyTermP t@TContainer{} = setPA initPA $ "" <+> prettyTerm t
 prettyTermP t = withPA initPA $ pretty t
@@ -629,12 +629,12 @@ instance Pretty Term where
     TWild -> text "_"
 
 -- | Print appropriate delimiters for a container literal.
-containerDelims :: Member (Reader PA) r => Container -> (Sem r (Doc ann) -> Sem r (Doc ann))
+containerDelims :: Member (Reader PA) r => Container -> (Sem r Doc -> Sem r Doc)
 containerDelims ListContainer = brackets
 containerDelims BagContainer = bag
 containerDelims SetContainer = braces
 
-prettyBranches :: Members '[Reader PA, LFresh] r => [Branch] -> Sem r (Doc ann)
+prettyBranches :: Members '[Reader PA, LFresh] r => [Branch] -> Sem r Doc
 prettyBranches = \case
   [] -> text ""
   b : bs ->
@@ -680,7 +680,7 @@ instance Pretty Qual where
     QGuard (unembed -> t) -> pretty t
 
 -- | Pretty-print a pattern with guaranteed parentheses.
-prettyPatternP :: Members '[LFresh, Reader PA] r => Pattern -> Sem r (Doc ann)
+prettyPatternP :: Members '[LFresh, Reader PA] r => Pattern -> Sem r Doc
 prettyPatternP p@PTup {} = setPA initPA $ pretty p
 prettyPatternP p = withPA initPA $ pretty p
 

src/Disco/Compile.hs

@@ -359,8 +359,6 @@ compilePrim _ PrimFrac = return $ CConst OFrac
 compilePrim _ PrimCrash = return $ CConst OCrash
 compilePrim _ PrimUntil = return $ CConst OUntil
 compilePrim _ PrimHolds = return $ CConst OHolds
-compilePrim _ PrimLookupSeq = return $ CConst OLookupSeq
-compilePrim _ PrimExtendSeq = return $ CConst OExtendSeq
 compilePrim ty PrimMin = desugaredPrimErr PrimMin ty
 compilePrim ty PrimMax = desugaredPrimErr PrimMax ty
 

src/Disco/Effects/Store.hs

@@ -1,10 +1,6 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE TemplateHaskell #-}
 
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
-
 -- |
 -- Module      :  Disco.Effects.Store
 -- Copyright   :  disco team and contributors
@@ -18,19 +14,20 @@ module Disco.Effects.Store where
 import qualified Data.IntMap.Lazy as IntMap
 import Data.IntSet (IntSet)
 import qualified Data.IntSet as IntSet
+import Data.Proxy
 
 import Disco.Effects.Counter
 import Polysemy
 import Polysemy.State
 
 data Store v m a where
-  ClearStore :: Store v m ()
+  ClearStore :: Proxy v -> Store v m ()
   New :: v -> Store v m Int
   LookupStore :: Int -> Store v m (Maybe v)
   InsertStore :: Int -> v -> Store v m ()
   MapStore :: (v -> v) -> Store v m ()
   AssocsStore :: Store v m [(Int, v)]
-  KeepKeys :: IntSet -> Store v m ()
+  KeepKeys :: Proxy v -> IntSet -> Store v m ()
 
 makeSem ''Store
 
@@ -40,7 +37,7 @@ runStore =
   runCounter
     . evalState @(IntMap.IntMap v) IntMap.empty
     . reinterpret2 \case
-      ClearStore -> put IntMap.empty
+      ClearStore _ -> put @(IntMap.IntMap v) IntMap.empty
       New v -> do
         loc <- fromIntegral <$> next
         modify $ IntMap.insert loc v
@@ -49,4 +46,6 @@ runStore =
       InsertStore k v -> modify (IntMap.insert k v)
       MapStore f -> modify (IntMap.map f)
       AssocsStore -> gets IntMap.assocs
-      KeepKeys ks -> modify (\m -> IntMap.withoutKeys m (IntMap.keysSet m `IntSet.difference` ks))
+      KeepKeys _ ks ->
+        modify @(IntMap.IntMap v) $ \m ->
+          IntMap.withoutKeys m (IntMap.keysSet m `IntSet.difference` ks)

src/Disco/Error.hs

@@ -78,7 +78,7 @@ deriving instance Show EvalError
 panic :: Member (Error DiscoError) r => String -> Sem r a
 panic = throw . Panic
 
-outputDiscoErrors :: Member (Output (Message ann)) r => Sem (Error DiscoError ': r) () -> Sem r ()
+outputDiscoErrors :: Member (Output Message) r => Sem (Error DiscoError ': r) () -> Sem r ()
 outputDiscoErrors m = do
   e <- runError m
   either (err . pretty') return e
@@ -102,10 +102,10 @@ instance Pretty DiscoError where
         , "Please report this as a bug at https://github.com/disco-lang/disco/issues/ ."
         ]
 
-rtd :: String -> Sem r (Doc ann)
+rtd :: String -> Sem r Doc
 rtd page = "https://disco-lang.readthedocs.io/en/latest/reference/" <> text page <> ".html"
 
--- issue :: Int -> Sem r (Doc ann)
+-- issue :: Int -> Sem r Doc
 -- issue n = "See https://github.com/disco-lang/disco/issues/" <> text (show n)
 
 squote :: String -> String
@@ -114,15 +114,15 @@ squote x = "'" ++ x ++ "'"
 cyclicImportError ::
   Members '[Reader PA, LFresh] r =>
   [ModuleName] ->
-  Sem r (Doc ann)
+  Sem r Doc
 cyclicImportError ms =
   nest 2 $
     vcat
       [ "Error: module imports form a cycle:"
       , intercalate " ->" (map pretty ms)
       ]
 
-prettyEvalError :: Members '[Reader PA, LFresh] r => EvalError -> Sem r (Doc ann)
+prettyEvalError :: Members '[Reader PA, LFresh] r => EvalError -> Sem r Doc
 prettyEvalError = \case
   UnboundPanic x ->
     ("Bug! No variable found named" <+> pretty' x <> ".")
@@ -139,7 +139,7 @@ prettyEvalError = \case
 -- [ ] Step 3: improve error messages according to notes below
 -- [ ] Step 4: get it to return multiple error messages
 -- [ ] Step 5: save parse locations, display with errors
-prettyTCError :: Members '[Reader PA, LFresh] r => TCError -> Sem r (Doc ann)
+prettyTCError :: Members '[Reader PA, LFresh] r => TCError -> Sem r Doc
 prettyTCError = \case
   -- XXX include some potential misspellings along with Unbound
   --   see https://github.com/disco-lang/disco/issues/180
@@ -261,13 +261,12 @@ prettyTCError = \case
       [ "Error: in the definition of " <> text s <> parens (intercalate "," (map text ss)) <> ": recursive occurrences of" <+> text s <+> "may only have type variables as arguments."
       , indent
           2
-          ( text s <> parens (intercalate "," (map pretty' tys)) <+> "does not follow this rule."
-          )
+          (text s <> parens (intercalate "," (map pretty' tys)) <+> "does not follow this rule.")
       , rtd "no-poly-rec"
       ]
   NoError -> empty
 
-conWord :: Con -> Sem r (Doc ann)
+conWord :: Con -> Sem r Doc
 conWord = \case
   CArr -> "function"
   CProd -> "pair"
@@ -280,7 +279,7 @@ conWord = \case
   CGraph -> "graph"
   CUser s -> text s
 
-prettySolveError :: Members '[Reader PA, LFresh] r => SolveError -> Sem r (Doc ann)
+prettySolveError :: Members '[Reader PA, LFresh] r => SolveError -> Sem r Doc
 prettySolveError = \case
   -- XXX say which types!
   NoWeakUnifier ->
@@ -311,12 +310,12 @@ prettySolveError = \case
       , rtd "qual-skolem"
       ]
 
-qualPhrase :: Bool -> Qualifier -> Sem r (Doc ann)
+qualPhrase :: Bool -> Qualifier -> Sem r Doc
 qualPhrase b q
   | q `elem` [QBool, QBasic, QSimple] = "are" <+> (if b then empty else "not") <+> qualAction q
   | otherwise = "can" <> (if b then empty else "not") <+> "be" <+> qualAction q
 
-qualAction :: Qualifier -> Sem r (Doc ann)
+qualAction :: Qualifier -> Sem r Doc
 qualAction = \case
   QNum -> "added and multiplied"
   QSub -> "subtracted"

src/Disco/Eval.hs

@@ -162,10 +162,10 @@ type family AppendEffects (r :: EffectRow) (s :: EffectRow) :: EffectRow where
 -- However, just manually implementing it here seems easier.
 
 -- | Effects needed at the top level.
-type TopEffects = '[Error DiscoError, State TopInfo, Output (Message ()), Embed IO, Final (H.InputT IO)]
+type TopEffects = '[Error DiscoError, State TopInfo, Output Message, Embed IO, Final (H.InputT IO)]
 
 -- | Effects needed for evaluation.
-type EvalEffects = [Error EvalError, Random, LFresh, Output (Message ()), State Mem]
+type EvalEffects = [Error EvalError, Random, LFresh, Output Message, State Mem]
 
 -- XXX write about order.
 -- memory, counter etc. should not be reset by errors.
@@ -191,11 +191,11 @@ runDisco cfg =
   void
     . H.runInputT inputSettings
     . runFinal @(H.InputT IO)
-    . embedToFinal
+    . embedToFinal @(H.InputT IO)
     . runEmbedded @_ @(H.InputT IO) liftIO
     . runOutputSem (handleMsg msgFilter) -- Handle Output Message via printing to console
     . stateToIO (initTopInfo cfg) -- Run State TopInfo via an IORef
-    . inputToState -- Dispatch Input TopInfo effect via State effect
+    . inputToState @TopInfo -- Dispatch Input TopInfo effect via State effect
     . runState emptyMem -- Start with empty memory
     . outputDiscoErrors -- Output any top-level errors
     . runLFresh -- Generate locally fresh names
@@ -293,7 +293,7 @@ typecheckTop tcm = do
 --   The 'Resolver' argument specifies where to look for imported
 --   modules.
 loadDiscoModule ::
-  Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r =>
+  Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r =>
   Bool ->
   Resolver ->
   FilePath ->
@@ -307,7 +307,7 @@ loadDiscoModule quiet resolver =
 --   module loaded from disk).  Used for e.g. blocks/modules entered
 --   at the REPL prompt.
 loadParsedDiscoModule ::
-  Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r =>
+  Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r =>
   Bool ->
   Resolver ->
   ModuleName ->
@@ -321,7 +321,7 @@ loadParsedDiscoModule quiet resolver =
 --   any imported module more than once. Resolve the module, load and
 --   parse it, then call 'loadParsedDiscoModule''.
 loadDiscoModule' ::
-  Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r =>
+  Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r =>
   Bool ->
   Resolver ->
   [ModuleName] ->
@@ -353,7 +353,7 @@ stdLib = ["list", "container"]
 --   'LoadingMode' parameter is 'REPL'.  Recursively load all its
 --   imports, then typecheck it.
 loadParsedDiscoModule' ::
-  Members '[State TopInfo, Output (Message ann), Random, State Mem, Error DiscoError, Embed IO] r =>
+  Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r =>
   Bool ->
   LoadingMode ->
   Resolver ->
@@ -399,7 +399,7 @@ loadParsedDiscoModule' quiet mode resolver inProcess name cm@(Module _ mns _ _ _
 
 -- | Try loading the contents of a file from the filesystem, emitting
 --   an error if it's not found.
-loadFile :: Members '[Output (Message ann), Embed IO] r => FilePath -> Sem r (Maybe String)
+loadFile :: Members '[Output Message, Embed IO] r => FilePath -> Sem r (Maybe String)
 loadFile file = do
   res <- liftIO $ handle @SomeException (return . Left) (Right <$> readFile file)
   case res of
@@ -409,7 +409,7 @@ loadFile file = do
 -- | Add things from the given module to the set of currently loaded
 --   things.
 addToREPLModule ::
-  Members '[Error DiscoError, State TopInfo, Random, State Mem, Output (Message ann)] r =>
+  Members '[Error DiscoError, State TopInfo, Random, State Mem, Output Message] r =>
   ModuleInfo ->
   Sem r ()
 addToREPLModule mi = modify @TopInfo (replModInfo <>~ mi)
@@ -419,7 +419,7 @@ addToREPLModule mi = modify @TopInfo (replModInfo <>~ mi)
 --   term definitions, documentation, types, and type definitions.
 --   Replaces any previously loaded module.
 setREPLModule ::
-  Members '[State TopInfo, Random, Error EvalError, State Mem, Output (Message ann)] r =>
+  Members '[State TopInfo, Random, Error EvalError, State Mem, Output Message] r =>
   ModuleInfo ->
   Sem r ()
 setREPLModule mi = do
@@ -450,7 +450,7 @@ loadDef x body = do
   v <- inputToState @TopInfo . inputTopEnv $ eval body
   modify @TopInfo $ topEnv %~ Ctx.insert x v
 
-checkExhaustive :: Members '[Fresh, Output (Message ann), Embed IO] r => TyDefCtx -> Defn -> Sem r ()
+checkExhaustive :: Members '[Fresh, Output Message, Embed IO] r => TyDefCtx -> Defn -> Sem r ()
 checkExhaustive tyDefCtx (Defn name argsType _ boundClauses) = do
   clauses <- NonEmpty.map fst <$> mapM unbind boundClauses
   runReader @TyDefCtx tyDefCtx $ checkClauses name argsType clauses