diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..e909fc5 --- /dev/null +++ b/.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"))) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..2c0e62b --- /dev/null +++ b/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 diff --git a/duet.cabal b/duet.cabal index b420999..4008d3d 100644 --- a/duet.cabal +++ b/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 diff --git a/src/Duet/Simple.hs b/src/Duet/Simple.hs new file mode 100644 index 0000000..58f59fd --- /dev/null +++ b/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 () diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..306053b --- /dev/null +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index 3f1a320..04df751 100644 --- a/test/Spec.hs +++ b/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 ()