mirror of
https://github.com/chrisdone/duet.git
synced 2024-10-26 03:18:46 +03:00
Add exe
This commit is contained in:
parent
3618877a30
commit
40eac4b3f0
5
.dir-locals.el
Normal file
5
.dir-locals.el
Normal file
@ -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")))
|
63
app/Main.hs
Normal file
63
app/Main.hs
Normal file
@ -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
|
19
duet.cabal
19
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
|
||||
|
110
src/Duet/Simple.hs
Normal file
110
src/Duet/Simple.hs
Normal file
@ -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 ()
|
19
stack.yaml.lock
Normal file
19
stack.yaml.lock
Normal file
@ -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
|
111
test/Spec.hs
111
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 ()
|
||||
|
Loading…
Reference in New Issue
Block a user