Add exe

.dir-locals.el

@@ -0,0 +1,5 @@
+;;; Directory Local Variables
+;;; For more information see (info "(emacs) Directory Variables")
+
+((haskell-mode
+  (intero-targets "duet:lib" "duet:exe:duet" "duet:test:duet-test")))

app/Main.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- |
+
+import Control.Monad.Logger
+import Control.Monad.Supply
+import Control.Monad.Writer
+import Data.Semigroup ((<>))
+import Duet.Infer
+import Duet.Parser
+import Duet.Printer
+import Duet.Simple
+import Options.Applicative.Simple
+
+data Run = Run
+  { runInputFile :: FilePath
+  , runMainIs :: String
+  , runSteps :: Int
+  } deriving (Show)
+
+main :: IO ()
+main = do
+  ((), cmd) <-
+    simpleOptions
+      "1.0"
+      "Duet interpreter"
+      "This is the interpreter for the Duet mini-Haskell educational language"
+      (pure ())
+      (addCommand
+         "run"
+         "Run the given program source"
+         runProgram
+         (Run <$>
+          strArgument (metavar "FILEPATH" <> help "The .hs file to interpret") <*>
+          strArgument
+            (metavar "NAME" <> help "The main value to run" <> value "main") <*>
+            argument auto
+              (metavar "NAME" <> help "The main value to run" <> value 100)))
+  cmd
+
+runProgram :: Run -> IO ()
+runProgram Run {..} = do
+  decls <- parseFile runInputFile
+  case runNoLoggingT
+         ((evalSupplyT
+             (do (binds, ctx) <- createContext decls
+                 things <-
+                   execWriterT
+                     (runStepper
+                        runSteps
+                        ctx
+                        (fmap (fmap typeSignatureA) binds)
+                        runMainIs)
+                 pure things)
+             [1 ..])) of
+    Left err -> print err
+    Right steps -> mapM_ (putStrLn . (++ "\n") . printExpression defaultPrint) steps

duet.cabal

@@ -41,6 +41,7 @@ library
     Duet.Supply
     Duet.Context
     Duet.Setup
+    Duet.Simple
     Control.Monad.Supply
 
 test-suite duet-test
@@ -62,3 +63,21 @@ test-suite duet-test
     syb,
     hspec,
     monad-logger
+
+executable duet
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  hs-source-dirs: app
+  ghc-options: -Wall
+  default-language: Haskell2010
+  build-depends:
+      base, duet,
+    containers,
+    mtl,
+    exceptions,
+    text,
+    deepseq,
+    aeson,
+    syb,
+    monad-logger,
+    optparse-simple

src/Duet/Simple.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- |
+
+module Duet.Simple where
+
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.Supply
+import Control.Monad.Writer
+import Duet.Context
+import Duet.Infer
+import Duet.Printer
+import Duet.Renamer
+import Duet.Resolver
+import Duet.Setup
+import Duet.Stepper
+import Duet.Types
+
+-- | Create a context of all renamed, checked and resolved code.
+createContext
+  :: (MonadSupply Int m, MonadCatch m)
+  => [Decl UnkindedType Identifier Location]
+  -> m ([BindGroup Type Name (TypeSignature Type Name Location)], Context Type Name Location)
+createContext decls = do
+  do builtins <-
+       setupEnv mempty [] >>=
+       traverse
+         (const
+            (pure
+               (Location
+                  { locationStartLine = 0
+                  , locationStartColumn = 0
+                  , locationEndLine = 0
+                  , locationEndColumn = 0
+                  })))
+     let specials = builtinsSpecials builtins
+     catch
+       (do (typeClasses, signatures, renamedBindings, scope, dataTypes) <-
+             renameEverything decls specials builtins
+           -- Type class definition
+           addedTypeClasses <- addClasses builtins typeClasses
+               -- Type checking
+           (bindGroups, typeCheckedClasses) <-
+             typeCheckModule
+               addedTypeClasses
+               signatures
+               (builtinsSpecialTypes builtins)
+               renamedBindings
+           -- Type class resolution
+           resolvedTypeClasses <-
+             resolveTypeClasses
+               typeCheckedClasses
+               (builtinsSpecialTypes builtins)
+           resolvedBindGroups <-
+             mapM
+               (resolveBindGroup
+                  resolvedTypeClasses
+                  (builtinsSpecialTypes builtins))
+               bindGroups
+           -- Create a context of everything
+           let ctx =
+                 Context
+                   { contextSpecialSigs = builtinsSpecialSigs builtins
+                   , contextSpecialTypes = builtinsSpecialTypes builtins
+                   , contextSignatures = signatures
+                   , contextScope = scope
+                   , contextTypeClasses = resolvedTypeClasses
+                   , contextDataTypes = dataTypes
+                   }
+           pure (resolvedBindGroups, ctx))
+       (throwM . ContextException (builtinsSpecialTypes builtins))
+
+-- | Run the substitution model on the code.
+runStepper
+  :: forall m. (MonadWriter [Expression Type Name ()] m, MonadSupply Int m, MonadThrow m)
+  => Int
+  -> Context Type Name Location
+  -> [BindGroup Type Name Location]
+  -> String
+  -> m ()
+runStepper maxSteps ctx bindGroups' i = do
+  e0 <- lookupNameByString i bindGroups'
+  loop 1 "" e0
+  where
+    loop ::
+         Int
+      -> String
+      -> Expression Type Name Location
+      -> m ()
+    loop count lastString e = do
+      e' <- expandSeq1 ctx bindGroups' e
+      let string = printExpression (defaultPrint) e
+      when (string /= lastString) (tell [fmap (const ()) e])
+      if (fmap (const ()) e' /= fmap (const ()) e) && count < maxSteps
+        then do
+          newE <-
+            renameExpression
+              (contextSpecials ctx)
+              (contextScope ctx)
+              (contextDataTypes ctx)
+              e'
+          loop (count + 1) string newE
+        else pure ()

stack.yaml.lock

@@ -0,0 +1,19 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: monad-supply-0.6@sha256:9d99848857bebde27d10bdeeb190ec2b409040114671b00928edfdc56d6d71e0,725
+    pantry-tree:
+      size: 222
+      sha256: 59fea76b03614e8788ea471564dbc4891c275ac4f6fa9bf341456ebbd7c6d647
+  original:
+    hackage: monad-supply-0.6
+snapshots:
+- completed:
+    size: 504336
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/12.yaml
+    sha256: 11db5c37144d13fe6b56cd511050b4e6ffe988f6edb8e439c2432fc9fcdf50c3
+  original: lts-12.12

test/Spec.hs

@@ -8,22 +8,15 @@
 
 -- |
 
-import           Control.Monad
-import           Control.Monad.Catch
-import           Control.Monad.Logger
-import           Control.Monad.Supply
-import           Control.Monad.Writer
-import           Data.Bifunctor
-import           Duet.Context
-import           Duet.Infer
-import           Duet.Parser
-import           Duet.Printer
-import           Duet.Renamer
-import           Duet.Resolver
-import           Duet.Setup
-import           Duet.Stepper
-import           Duet.Types
-import           Test.Hspec
+import Control.Monad.Logger
+import Control.Monad.Supply
+import Control.Monad.Writer
+import Data.Bifunctor
+import Duet.Infer
+import Duet.Parser
+import Duet.Simple
+import Duet.Types
+import Test.Hspec
 
 main :: IO ()
 main = hspec spec
@@ -84,89 +77,3 @@ spec =
                     (LiteralExpression () (IntegerLiteral 1))
                 , LiteralExpression () (IntegerLiteral 1)
                 ])))
-
--- | Create a context of all renamed, checked and resolved code.
-createContext
-  :: (MonadSupply Int m, MonadCatch m)
-  => [Decl UnkindedType Identifier Location]
-  -> m ([BindGroup Type Name (TypeSignature Type Name Location)], Context Type Name Location)
-createContext decls = do
-  do builtins <-
-       setupEnv mempty [] >>=
-       traverse
-         (const
-            (pure
-               (Location
-                  { locationStartLine = 0
-                  , locationStartColumn = 0
-                  , locationEndLine = 0
-                  , locationEndColumn = 0
-                  })))
-     let specials = builtinsSpecials builtins
-     catch
-       (do (typeClasses, signatures, renamedBindings, scope, dataTypes) <-
-             renameEverything decls specials builtins
-           -- Type class definition
-           addedTypeClasses <- addClasses builtins typeClasses
-               -- Type checking
-           (bindGroups, typeCheckedClasses) <-
-             typeCheckModule
-               addedTypeClasses
-               signatures
-               (builtinsSpecialTypes builtins)
-               renamedBindings
-           -- Type class resolution
-           resolvedTypeClasses <-
-             resolveTypeClasses
-               typeCheckedClasses
-               (builtinsSpecialTypes builtins)
-           resolvedBindGroups <-
-             mapM
-               (resolveBindGroup
-                  resolvedTypeClasses
-                  (builtinsSpecialTypes builtins))
-               bindGroups
-           -- Create a context of everything
-           let ctx =
-                 Context
-                   { contextSpecialSigs = builtinsSpecialSigs builtins
-                   , contextSpecialTypes = builtinsSpecialTypes builtins
-                   , contextSignatures = signatures
-                   , contextScope = scope
-                   , contextTypeClasses = resolvedTypeClasses
-                   , contextDataTypes = dataTypes
-                   }
-           pure (resolvedBindGroups, ctx))
-       (throwM . ContextException (builtinsSpecialTypes builtins))
-
--- | Run the substitution model on the code.
-runStepper
-  :: forall m. (MonadWriter [Expression Type Name ()] m, MonadSupply Int m, MonadThrow m)
-  => Int
-  -> Context Type Name Location
-  -> [BindGroup Type Name Location]
-  -> String
-  -> m ()
-runStepper maxSteps ctx bindGroups' i = do
-  e0 <- lookupNameByString i bindGroups'
-  loop 1 "" e0
-  where
-    loop ::
-         Int
-      -> String
-      -> Expression Type Name Location
-      -> m ()
-    loop count lastString e = do
-      e' <- expandSeq1 ctx bindGroups' e
-      let string = printExpression (defaultPrint) e
-      when (string /= lastString) (tell [fmap (const ()) e])
-      if (fmap (const ()) e' /= fmap (const ()) e) && count < maxSteps
-        then do
-          newE <-
-            renameExpression
-              (contextSpecials ctx)
-              (contextScope ctx)
-              (contextDataTypes ctx)
-              e'
-          loop (count + 1) string newE
-        else pure ()