mirror of
https://github.com/chrisdone-archive/duet.git
synced 2024-10-05 21:57:49 +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.Supply
|
||||||
Duet.Context
|
Duet.Context
|
||||||
Duet.Setup
|
Duet.Setup
|
||||||
|
Duet.Simple
|
||||||
Control.Monad.Supply
|
Control.Monad.Supply
|
||||||
|
|
||||||
test-suite duet-test
|
test-suite duet-test
|
||||||
@ -62,3 +63,21 @@ test-suite duet-test
|
|||||||
syb,
|
syb,
|
||||||
hspec,
|
hspec,
|
||||||
monad-logger
|
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.Logger
|
||||||
import Control.Monad.Catch
|
import Control.Monad.Supply
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Writer
|
||||||
import Control.Monad.Supply
|
import Data.Bifunctor
|
||||||
import Control.Monad.Writer
|
import Duet.Infer
|
||||||
import Data.Bifunctor
|
import Duet.Parser
|
||||||
import Duet.Context
|
import Duet.Simple
|
||||||
import Duet.Infer
|
import Duet.Types
|
||||||
import Duet.Parser
|
import Test.Hspec
|
||||||
import Duet.Printer
|
|
||||||
import Duet.Renamer
|
|
||||||
import Duet.Resolver
|
|
||||||
import Duet.Setup
|
|
||||||
import Duet.Stepper
|
|
||||||
import Duet.Types
|
|
||||||
import Test.Hspec
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = hspec spec
|
main = hspec spec
|
||||||
@ -84,89 +77,3 @@ spec =
|
|||||||
(LiteralExpression () (IntegerLiteral 1))
|
(LiteralExpression () (IntegerLiteral 1))
|
||||||
, 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