I'm OK
This commit is contained in:
commit
2783fd2740
2
.gitignore
vendored
Normal file
2
.gitignore
vendored
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
.stack-work/
|
||||||
|
*~
|
||||||
6
.vscode/settings.json
vendored
Normal file
6
.vscode/settings.json
vendored
Normal file
@ -0,0 +1,6 @@
|
|||||||
|
{
|
||||||
|
"cSpell.words": [
|
||||||
|
"elems",
|
||||||
|
"foldr"
|
||||||
|
]
|
||||||
|
}
|
||||||
11
CHANGELOG.md
Normal file
11
CHANGELOG.md
Normal file
@ -0,0 +1,11 @@
|
|||||||
|
# Changelog for `meo`
|
||||||
|
|
||||||
|
All notable changes to this project will be documented in this file.
|
||||||
|
|
||||||
|
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
|
||||||
|
and this project adheres to the
|
||||||
|
[Haskell Package Versioning Policy](https://pvp.haskell.org/).
|
||||||
|
|
||||||
|
## Unreleased
|
||||||
|
|
||||||
|
## 0.1.0.0 - YYYY-MM-DD
|
||||||
30
LICENSE
Normal file
30
LICENSE
Normal file
@ -0,0 +1,30 @@
|
|||||||
|
Copyright Author name here (c) 2023
|
||||||
|
|
||||||
|
All rights reserved.
|
||||||
|
|
||||||
|
Redistribution and use in source and binary forms, with or without
|
||||||
|
modification, are permitted provided that the following conditions are met:
|
||||||
|
|
||||||
|
* Redistributions of source code must retain the above copyright
|
||||||
|
notice, this list of conditions and the following disclaimer.
|
||||||
|
|
||||||
|
* Redistributions in binary form must reproduce the above
|
||||||
|
copyright notice, this list of conditions and the following
|
||||||
|
disclaimer in the documentation and/or other materials provided
|
||||||
|
with the distribution.
|
||||||
|
|
||||||
|
* Neither the name of Author name here nor the names of other
|
||||||
|
contributors may be used to endorse or promote products derived
|
||||||
|
from this software without specific prior written permission.
|
||||||
|
|
||||||
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||||
|
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||||
|
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||||
|
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||||
|
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||||
|
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||||
|
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||||
|
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||||
|
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
7
app/Main.hs
Normal file
7
app/Main.hs
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
module Main (main) where
|
||||||
|
|
||||||
|
import Lib (mainIO)
|
||||||
|
import Premitive (ttest)
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = mainIO
|
||||||
91
meo.cabal
Normal file
91
meo.cabal
Normal file
@ -0,0 +1,91 @@
|
|||||||
|
cabal-version: 2.2
|
||||||
|
|
||||||
|
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||||
|
--
|
||||||
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
|
name: meo
|
||||||
|
version: 0.1.0.0
|
||||||
|
description: Please see the README on GitHub at <https://github.com/githubuser/meo#readme>
|
||||||
|
homepage: https://github.com/githubuser/meo#readme
|
||||||
|
bug-reports: https://github.com/githubuser/meo/issues
|
||||||
|
author: Author name here
|
||||||
|
maintainer: example@example.com
|
||||||
|
copyright: 2023 Author name here
|
||||||
|
license: BSD-3-Clause
|
||||||
|
license-file: LICENSE
|
||||||
|
build-type: Simple
|
||||||
|
extra-source-files:
|
||||||
|
README.md
|
||||||
|
CHANGELOG.md
|
||||||
|
|
||||||
|
source-repository head
|
||||||
|
type: git
|
||||||
|
location: https://github.com/githubuser/meo
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules:
|
||||||
|
Ast
|
||||||
|
Lib
|
||||||
|
Premitive
|
||||||
|
Type
|
||||||
|
other-modules:
|
||||||
|
Paths_meo
|
||||||
|
autogen-modules:
|
||||||
|
Paths_meo
|
||||||
|
hs-source-dirs:
|
||||||
|
src
|
||||||
|
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
|
||||||
|
build-depends:
|
||||||
|
base >=4.7 && <5
|
||||||
|
, cmdargs
|
||||||
|
, containers
|
||||||
|
, exceptions
|
||||||
|
, monad-logger
|
||||||
|
, mtl
|
||||||
|
, parsec
|
||||||
|
, text
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
executable meo-exe
|
||||||
|
main-is: Main.hs
|
||||||
|
other-modules:
|
||||||
|
Paths_meo
|
||||||
|
autogen-modules:
|
||||||
|
Paths_meo
|
||||||
|
hs-source-dirs:
|
||||||
|
app
|
||||||
|
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
|
||||||
|
build-depends:
|
||||||
|
base >=4.7 && <5
|
||||||
|
, cmdargs
|
||||||
|
, containers
|
||||||
|
, exceptions
|
||||||
|
, meo
|
||||||
|
, monad-logger
|
||||||
|
, mtl
|
||||||
|
, parsec
|
||||||
|
, text
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
test-suite meo-test
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Spec.hs
|
||||||
|
other-modules:
|
||||||
|
Paths_meo
|
||||||
|
autogen-modules:
|
||||||
|
Paths_meo
|
||||||
|
hs-source-dirs:
|
||||||
|
test
|
||||||
|
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
|
||||||
|
build-depends:
|
||||||
|
base >=4.7 && <5
|
||||||
|
, cmdargs
|
||||||
|
, containers
|
||||||
|
, exceptions
|
||||||
|
, meo
|
||||||
|
, monad-logger
|
||||||
|
, mtl
|
||||||
|
, parsec
|
||||||
|
, text
|
||||||
|
default-language: Haskell2010
|
||||||
66
package.yaml
Normal file
66
package.yaml
Normal file
@ -0,0 +1,66 @@
|
|||||||
|
name: meo
|
||||||
|
version: 0.1.0.0
|
||||||
|
github: "githubuser/meo"
|
||||||
|
license: BSD-3-Clause
|
||||||
|
author: "Author name here"
|
||||||
|
maintainer: "example@example.com"
|
||||||
|
copyright: "2023 Author name here"
|
||||||
|
|
||||||
|
extra-source-files:
|
||||||
|
- README.md
|
||||||
|
- CHANGELOG.md
|
||||||
|
|
||||||
|
# Metadata used when publishing your package
|
||||||
|
# synopsis: Short description of your package
|
||||||
|
# category: Web
|
||||||
|
|
||||||
|
# To avoid duplicated efforts in documentation and dealing with the
|
||||||
|
# complications of embedding Haddock markup inside cabal files, it is
|
||||||
|
# common to point users to the README.md file.
|
||||||
|
description: Please see the README on GitHub at <https://github.com/githubuser/meo#readme>
|
||||||
|
|
||||||
|
dependencies:
|
||||||
|
- base >= 4.7 && < 5
|
||||||
|
- parsec
|
||||||
|
- mtl
|
||||||
|
- containers
|
||||||
|
- text
|
||||||
|
- cmdargs
|
||||||
|
- exceptions
|
||||||
|
- monad-logger
|
||||||
|
|
||||||
|
ghc-options:
|
||||||
|
- -Wall
|
||||||
|
- -Wcompat
|
||||||
|
- -Widentities
|
||||||
|
- -Wincomplete-record-updates
|
||||||
|
- -Wincomplete-uni-patterns
|
||||||
|
- -Wmissing-export-lists
|
||||||
|
- -Wmissing-home-modules
|
||||||
|
- -Wpartial-fields
|
||||||
|
- -Wredundant-constraints
|
||||||
|
|
||||||
|
library:
|
||||||
|
source-dirs: src
|
||||||
|
|
||||||
|
executables:
|
||||||
|
meo-exe:
|
||||||
|
main: Main.hs
|
||||||
|
source-dirs: app
|
||||||
|
ghc-options:
|
||||||
|
- -threaded
|
||||||
|
- -rtsopts
|
||||||
|
- -with-rtsopts=-N
|
||||||
|
dependencies:
|
||||||
|
- meo
|
||||||
|
|
||||||
|
tests:
|
||||||
|
meo-test:
|
||||||
|
main: Spec.hs
|
||||||
|
source-dirs: test
|
||||||
|
ghc-options:
|
||||||
|
- -threaded
|
||||||
|
- -rtsopts
|
||||||
|
- -with-rtsopts=-N
|
||||||
|
dependencies:
|
||||||
|
- meo
|
||||||
73
src/Ast.hs
Normal file
73
src/Ast.hs
Normal file
@ -0,0 +1,73 @@
|
|||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
module Ast where
|
||||||
|
import Foreign (Storable)
|
||||||
|
import Premitive (Expr,Stmt)
|
||||||
|
|
||||||
|
|
||||||
|
type Location = Int
|
||||||
|
type Index = [String]
|
||||||
|
type Stack = [Int]
|
||||||
|
|
||||||
|
|
||||||
|
position :: String -> Index -> Location
|
||||||
|
position name index = let pos n (nm:nms) =
|
||||||
|
if name == nm
|
||||||
|
then n
|
||||||
|
else pos (n+1) nms
|
||||||
|
pos _ [] = -1
|
||||||
|
in pos 1 index
|
||||||
|
|
||||||
|
fetch :: Location -> Stack -> Int
|
||||||
|
fetch n (v:vs) = if n == 1
|
||||||
|
then v
|
||||||
|
else fetch (n-1) vs
|
||||||
|
fetch _ [] = -1
|
||||||
|
|
||||||
|
put :: Location -> Int -> Stack -> Stack
|
||||||
|
put n x (v:vs) = if n == 1
|
||||||
|
then x:vs
|
||||||
|
else v:put (n-1) x vs
|
||||||
|
|
||||||
|
put _ _ [] = []
|
||||||
|
|
||||||
|
|
||||||
|
newtype M a = StOut (Stack -> (a, Stack, String))
|
||||||
|
|
||||||
|
unStOut :: M a -> Stack -> (a, Stack, String)
|
||||||
|
unStOut (StOut o) = o
|
||||||
|
|
||||||
|
instance Functor M where
|
||||||
|
fmap f e = StOut (\n -> let (a,n1,s1) = unStOut e n in
|
||||||
|
(f a, n1, s1)
|
||||||
|
)
|
||||||
|
|
||||||
|
instance Applicative M where
|
||||||
|
pure x = StOut (x,,"")
|
||||||
|
ef <*> e = StOut (\n -> let (f,n1,s1) = unStOut ef n
|
||||||
|
(a,n2,s2) = unStOut e n1 in
|
||||||
|
(f a, n2, s1++s2)
|
||||||
|
)
|
||||||
|
|
||||||
|
instance Monad M where
|
||||||
|
return = pure
|
||||||
|
e >>= f = StOut (\n -> let (a,n1,s1) = unStOut e n
|
||||||
|
(b,n2,s2) = unStOut (f a) n1 in
|
||||||
|
(b, n2, s1++s2)
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
getFrom :: Location -> M Int
|
||||||
|
getFrom i = StOut (\ns -> (fetch i ns, ns, ""))
|
||||||
|
|
||||||
|
|
||||||
|
write :: Location -> Int -> M ()
|
||||||
|
write i v = StOut (\ns -> (() , put i v ns, ""))
|
||||||
|
|
||||||
|
push :: Int -> M ()
|
||||||
|
push x = StOut (\ns -> ((), x:ns, ""))
|
||||||
|
|
||||||
|
pop :: M ()
|
||||||
|
pop = StOut (\(_:ns) -> ((), ns,""))
|
||||||
|
|
||||||
|
output :: Show a => a -> M ()
|
||||||
|
output v = StOut ((), , show v)
|
||||||
30
src/Lib.hs
Normal file
30
src/Lib.hs
Normal file
@ -0,0 +1,30 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Lib (mainIO) where
|
||||||
|
|
||||||
|
import Control.Exception (SomeException)
|
||||||
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
import Control.Monad.Logger
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import qualified Data.Text.IO as TIO
|
||||||
|
import System.IO.Error (isDoesNotExistError)
|
||||||
|
|
||||||
|
data Config = Config
|
||||||
|
{ -- | Path to the log file
|
||||||
|
configLogLevel :: LogLevel -- 日志级别
|
||||||
|
}
|
||||||
|
|
||||||
|
type App = ReaderT Config (LoggingT IO)
|
||||||
|
|
||||||
|
-- 日志记录和读取配置的函数
|
||||||
|
appFunction :: App ()
|
||||||
|
appFunction = do
|
||||||
|
Config logLevel <- ask
|
||||||
|
lift $ filterLogger (\_ level -> level >= logLevel) $ do
|
||||||
|
logInfoN "This is an informational message."
|
||||||
|
logDebugN "This is a debug message."
|
||||||
|
|
||||||
|
mainIO :: IO ()
|
||||||
|
mainIO = do
|
||||||
|
let config = Config LevelInfo
|
||||||
|
runStdoutLoggingT $ runReaderT appFunction config
|
||||||
209
src/Premitive.hs
Normal file
209
src/Premitive.hs
Normal file
@ -0,0 +1,209 @@
|
|||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
|
|
||||||
|
module Premitive (ttest, Stmt, Expr (..)) where
|
||||||
|
|
||||||
|
import Data.Functor.Identity
|
||||||
|
import Text.Parsec
|
||||||
|
import qualified Text.Parsec.Expr as E
|
||||||
|
import Text.Parsec.Language
|
||||||
|
import Text.Parsec.String
|
||||||
|
import qualified Text.Parsec.Token as T
|
||||||
|
|
||||||
|
types :: [String]
|
||||||
|
types = ["number", "bool", "string", "list", "nil", "func"]
|
||||||
|
|
||||||
|
reservedNames :: [String]
|
||||||
|
reservedNames = ["if", "then", "else", "while", "do", "process", "pipeline", "in", "()", "skip", "declare", "func"] ++ types
|
||||||
|
|
||||||
|
reservedOpNames :: [String]
|
||||||
|
reservedOpNames = ["+", "-", "*", "/", ":=", "==", "<", ">", "&&", "||", "!", ";", "|", ">>>", "<<<", ">>", "<<"]
|
||||||
|
|
||||||
|
-- 定义语言
|
||||||
|
languageDef =
|
||||||
|
emptyDef
|
||||||
|
{ T.commentStart = "/*",
|
||||||
|
T.commentEnd = "*/",
|
||||||
|
T.commentLine = "//",
|
||||||
|
T.nestedComments = True,
|
||||||
|
T.identStart = letter :: Parser Char,
|
||||||
|
T.identLetter = alphaNum :: Parser Char,
|
||||||
|
T.opStart = oneOf "+-*/",
|
||||||
|
T.opLetter = oneOf "+-*/",
|
||||||
|
T.reservedOpNames = reservedOpNames,
|
||||||
|
T.reservedNames = reservedNames
|
||||||
|
}
|
||||||
|
|
||||||
|
-- 创建 TokenParser
|
||||||
|
lexer = T.makeTokenParser languageDef
|
||||||
|
|
||||||
|
data Stmt
|
||||||
|
= If Expr Stmt Stmt
|
||||||
|
| While Expr Stmt
|
||||||
|
| Assign String Expr
|
||||||
|
| Seq Stmt Stmt
|
||||||
|
| Skip
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
data Ks = Ks String Expr deriving (Show)
|
||||||
|
|
||||||
|
ksTerm :: Parser Ks
|
||||||
|
ksTerm = do
|
||||||
|
k <- T.identifier lexer <* T.colon lexer
|
||||||
|
Ks k <$> expr
|
||||||
|
|
||||||
|
data IntOrFloat = IntValue Integer | FloatValue Double deriving (Show)
|
||||||
|
|
||||||
|
-- 定义算术表达式的数据类型
|
||||||
|
data Expr
|
||||||
|
= Num IntOrFloat
|
||||||
|
| Bool Bool
|
||||||
|
| Nil
|
||||||
|
| Str String
|
||||||
|
| Pipeln String [Expr]
|
||||||
|
| List [Expr]
|
||||||
|
| Process String [Ks]
|
||||||
|
| Block Stmt Expr
|
||||||
|
| Symbol String
|
||||||
|
| IfExpr Expr Expr Expr
|
||||||
|
| Declare [String] [Expr] Expr
|
||||||
|
| Bin String Expr Expr
|
||||||
|
| Con Expr Expr
|
||||||
|
| Func String Expr
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
data BasicType = NumberType | BoolType | StringType | ListType | NilType | FuncType BasicType BasicType deriving (Show)
|
||||||
|
|
||||||
|
prefix :: String -> (Expr -> Expr) -> E.Operator String () Identity Expr
|
||||||
|
prefix name fun = E.Prefix (do _ <- T.reservedOp lexer name; return fun)
|
||||||
|
|
||||||
|
binary :: String -> (Expr -> Expr -> Expr) -> E.Operator String () Identity Expr
|
||||||
|
binary name fun = E.Infix (T.reservedOp lexer name >> return fun) E.AssocLeft
|
||||||
|
|
||||||
|
postfix :: String -> (Expr -> Expr) -> E.Operator String () Identity Expr
|
||||||
|
postfix name fun = E.Postfix (do T.reservedOp lexer name; return fun)
|
||||||
|
|
||||||
|
pattern Mul :: Expr -> Expr -> Expr
|
||||||
|
pattern Mul a b = Bin "*" a b
|
||||||
|
|
||||||
|
pattern Div :: Expr -> Expr -> Expr
|
||||||
|
pattern Div a b = Bin "/" a b
|
||||||
|
|
||||||
|
pattern Add :: Expr -> Expr -> Expr
|
||||||
|
pattern Add a b = Bin "+" a b
|
||||||
|
|
||||||
|
pattern Sub :: Expr -> Expr -> Expr
|
||||||
|
pattern Sub a b = Bin "-" a b
|
||||||
|
|
||||||
|
-- 运算符表及其优先级和结合性
|
||||||
|
table :: E.OperatorTable String () Identity Expr
|
||||||
|
table =
|
||||||
|
[ [binary "*" Mul, binary "/" Div],
|
||||||
|
[binary "+" Add, binary "-" Sub],
|
||||||
|
[binary ">>>" Con]
|
||||||
|
]
|
||||||
|
|
||||||
|
-- 定义换行分隔的解析器
|
||||||
|
lineSepBy :: Parser a -> Parser [a]
|
||||||
|
lineSepBy element = sepBy element newline
|
||||||
|
|
||||||
|
parserProcess :: Parser Expr
|
||||||
|
parserProcess = do
|
||||||
|
T.reserved lexer "process"
|
||||||
|
name <- T.identifier lexer
|
||||||
|
T.braces lexer $ do
|
||||||
|
args <- T.semiSep lexer ksTerm
|
||||||
|
return $ Process name args
|
||||||
|
|
||||||
|
-- 整数解析器
|
||||||
|
numberParser :: Parser Expr
|
||||||
|
numberParser =
|
||||||
|
Num <$> do
|
||||||
|
nf <- T.naturalOrFloat lexer
|
||||||
|
case nf of
|
||||||
|
Left i -> return $ IntValue i
|
||||||
|
Right r -> return $ FloatValue r
|
||||||
|
|
||||||
|
nilParser :: Parser Expr
|
||||||
|
nilParser = T.brackets lexer (return Nil)
|
||||||
|
|
||||||
|
blockParser :: Parser Expr
|
||||||
|
blockParser = T.reserved lexer "do" >> T.braces lexer (Block <$> option Skip stmt <*> option Nil expr)
|
||||||
|
|
||||||
|
expr :: ParsecT String () Identity Expr
|
||||||
|
expr = E.buildExpressionParser table term <?> "expression"
|
||||||
|
|
||||||
|
basicTermParser :: Parser Expr
|
||||||
|
basicTermParser = try blockParser <|> Str <$> T.stringLiteral lexer <|> numberParser <|> nilParser <|> Symbol <$> T.identifier lexer <|> List <$> T.brackets lexer (T.commaSep lexer basicTermParser)
|
||||||
|
|
||||||
|
term :: Parser Expr
|
||||||
|
term = T.parens lexer expr <|> basicTermParser <|> parserProcess <?> "simple expression"
|
||||||
|
|
||||||
|
-- 语句解析器
|
||||||
|
stmt :: Parser Stmt
|
||||||
|
stmt = try seqStmt <|> ifStmt <|> whileStmt <|> assignStmt <|> skipStmt <?> "statement"
|
||||||
|
|
||||||
|
basicStmt :: Parser Stmt
|
||||||
|
basicStmt = ifStmt <|> whileStmt <?> "statement"
|
||||||
|
|
||||||
|
ifExpr :: Parser Expr
|
||||||
|
ifExpr = do
|
||||||
|
T.reserved lexer "if"
|
||||||
|
cond <- expr
|
||||||
|
T.reserved lexer "then"
|
||||||
|
expr1 <- expr
|
||||||
|
T.reserved lexer "else"
|
||||||
|
IfExpr cond expr1 <$> expr
|
||||||
|
|
||||||
|
ifStmt :: Parser Stmt
|
||||||
|
ifStmt = do
|
||||||
|
T.reserved lexer "if"
|
||||||
|
cond <- expr
|
||||||
|
T.reserved lexer "then"
|
||||||
|
stmt1 <- stmt
|
||||||
|
T.reserved lexer "else"
|
||||||
|
If cond stmt1 <$> stmt
|
||||||
|
|
||||||
|
whileStmt :: Parser Stmt
|
||||||
|
whileStmt = do
|
||||||
|
T.reserved lexer "while"
|
||||||
|
cond <- expr
|
||||||
|
T.reserved lexer "do"
|
||||||
|
While cond <$> stmt
|
||||||
|
|
||||||
|
assignStmt :: Parser Stmt
|
||||||
|
assignStmt = do
|
||||||
|
var <- T.identifier lexer
|
||||||
|
T.reservedOp lexer ":="
|
||||||
|
Assign var <$> expr
|
||||||
|
|
||||||
|
declareExpr :: Parser Expr
|
||||||
|
declareExpr = do
|
||||||
|
T.reserved lexer "declare"
|
||||||
|
v <- T.semiSep1 lexer $ do
|
||||||
|
var <- T.identifier lexer
|
||||||
|
T.reservedOp lexer ":="
|
||||||
|
val <- expr
|
||||||
|
return (var, val)
|
||||||
|
T.reservedOp lexer "in"
|
||||||
|
let (var, val) = unzip v
|
||||||
|
in Declare var val <$> expr
|
||||||
|
|
||||||
|
skipStmt :: Parser Stmt
|
||||||
|
skipStmt = T.reserved lexer "skip" >> return Skip
|
||||||
|
|
||||||
|
seqStmt :: Parser Stmt
|
||||||
|
seqStmt = do
|
||||||
|
stmt1 <- basicStmt
|
||||||
|
_ <- T.semi lexer
|
||||||
|
Seq stmt1 <$> stmt
|
||||||
|
|
||||||
|
parseExpr :: String -> Either ParseError Stmt
|
||||||
|
parseExpr = parse stmt ""
|
||||||
|
|
||||||
|
ttest :: IO ()
|
||||||
|
ttest = do
|
||||||
|
putStrLn "Enter a simple arithmetic expression:"
|
||||||
|
input <- getLine
|
||||||
|
case parseExpr input of
|
||||||
|
Left err -> print err
|
||||||
|
Right x -> print x
|
||||||
149
src/Type.hs
Normal file
149
src/Type.hs
Normal file
@ -0,0 +1,149 @@
|
|||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
|
|
||||||
|
module Type where
|
||||||
|
|
||||||
|
import Control.Monad.Except
|
||||||
|
import Control.Monad.RWS as R
|
||||||
|
( MonadReader (ask, local),
|
||||||
|
MonadState (get, put),
|
||||||
|
MonadWriter (tell),
|
||||||
|
RWST,
|
||||||
|
)
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import qualified Premitive as P
|
||||||
|
|
||||||
|
type Name = String
|
||||||
|
|
||||||
|
newtype TVar = TV Name deriving (Eq, Show, Ord)
|
||||||
|
|
||||||
|
data Type
|
||||||
|
= TCon Name [Type]
|
||||||
|
| TVar TVar
|
||||||
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
|
pattern TInt = TCon "Int" []
|
||||||
|
|
||||||
|
pattern TBool = TCon "Bool" []
|
||||||
|
|
||||||
|
pattern a :-> b = TCon "->" [a, b]
|
||||||
|
|
||||||
|
pattern TNumber = TCon "Number" []
|
||||||
|
|
||||||
|
pattern TList a = TCon "List" [a]
|
||||||
|
|
||||||
|
pattern TNil = TCon "Nil" []
|
||||||
|
|
||||||
|
data Scheme = Forall (Set.Set TVar) Type
|
||||||
|
|
||||||
|
data Constraint = Constraint Type Type
|
||||||
|
|
||||||
|
type Context = Map.Map Name Scheme
|
||||||
|
|
||||||
|
type Count = Int
|
||||||
|
|
||||||
|
type Constraints = [Constraint]
|
||||||
|
|
||||||
|
type Infer a = RWST Context Constraints Count (Except String) a
|
||||||
|
|
||||||
|
-- constrain :: Type -> Type -> Infer ()
|
||||||
|
-- constrain t1 t2 = tell [Constraint t1 t2]
|
||||||
|
|
||||||
|
fresh :: Infer Type
|
||||||
|
fresh = do
|
||||||
|
count <- get
|
||||||
|
put (count + 1)
|
||||||
|
return . TVar . TV $ show count
|
||||||
|
|
||||||
|
type Subst = Map.Map TVar Type
|
||||||
|
|
||||||
|
compose :: Subst -> Subst -> Subst
|
||||||
|
compose a b = Map.map (apply a) (b `Map.union` a)
|
||||||
|
|
||||||
|
class Substitutable a where
|
||||||
|
apply :: Subst -> a -> a
|
||||||
|
tvs :: a -> Set.Set TVar
|
||||||
|
|
||||||
|
instance Substitutable Type where
|
||||||
|
tvs (TVar tv) = Set.singleton tv
|
||||||
|
tvs (TCon _ ts) = foldr (Set.union . tvs) Set.empty ts
|
||||||
|
apply s t@(TVar tv) = Map.findWithDefault t tv s
|
||||||
|
apply s (TCon c ts) = TCon c $ map (apply s) ts
|
||||||
|
|
||||||
|
instance Substitutable Scheme where
|
||||||
|
tvs (Forall vs t) = tvs t `Set.difference` vs
|
||||||
|
apply s (Forall vs t) = Forall vs $ apply (foldr Map.delete s vs) t
|
||||||
|
|
||||||
|
instance Substitutable Constraint where
|
||||||
|
tvs (Constraint t1 t2) = tvs t1 `Set.union` tvs t2
|
||||||
|
apply s (Constraint t1 t2) = Constraint (apply s t1) (apply s t2)
|
||||||
|
|
||||||
|
instance (Substitutable a) => Substitutable [a] where
|
||||||
|
apply s = map (apply s)
|
||||||
|
tvs = foldr (Set.union . tvs) Set.empty
|
||||||
|
|
||||||
|
generalize :: Context -> Type -> Scheme
|
||||||
|
generalize ctx t = Forall (tvs t `Set.difference` tvs (Map.elems ctx)) t
|
||||||
|
|
||||||
|
instantiate :: Scheme -> Infer Type
|
||||||
|
instantiate (Forall vs t) = do
|
||||||
|
let vars = Set.toList vs
|
||||||
|
ftvs <- traverse (const fresh) vars
|
||||||
|
let subst = Map.fromList (zip vars ftvs)
|
||||||
|
return $ apply subst t
|
||||||
|
|
||||||
|
constrain :: Type -> Type -> Infer ()
|
||||||
|
constrain a b = tell [Constraint a b]
|
||||||
|
|
||||||
|
infer :: P.Expr -> Infer Type
|
||||||
|
infer e = case e of
|
||||||
|
P.Num _ -> return TInt
|
||||||
|
P.Bool _ -> return TBool -- Boolean literal
|
||||||
|
P.IfExpr e1 e2 e3 -> do
|
||||||
|
-- If expression
|
||||||
|
t1 <- infer e1
|
||||||
|
constrain t1 TBool
|
||||||
|
t2 <- infer e2
|
||||||
|
t3 <- infer e3
|
||||||
|
constrain t2 t3
|
||||||
|
return t2
|
||||||
|
P.Bin op e1 e2 -> do
|
||||||
|
-- Binary operator
|
||||||
|
t1 <- infer e1
|
||||||
|
t2 <- infer e2
|
||||||
|
constrain t1 TInt
|
||||||
|
constrain t2 TInt
|
||||||
|
case op of
|
||||||
|
"+" -> return TInt
|
||||||
|
"-" -> return TInt
|
||||||
|
"*" -> return TInt
|
||||||
|
"/" -> return TInt
|
||||||
|
_ -> throwError $ "unknown operator: " ++ op
|
||||||
|
P.Con e1 e2 -> do
|
||||||
|
t1 <- infer e1
|
||||||
|
t2 <- infer e2
|
||||||
|
constrain t1 t2
|
||||||
|
return t2
|
||||||
|
P.Nil -> do
|
||||||
|
return TNil
|
||||||
|
P.List es -> do
|
||||||
|
ts <- traverse infer es
|
||||||
|
return $ TList (head ts)
|
||||||
|
P.Symbol s -> do
|
||||||
|
ctx <- ask
|
||||||
|
case Map.lookup s ctx of
|
||||||
|
Nothing -> throwError $ "unbound variable: " ++ s
|
||||||
|
Just s' -> instantiate s'
|
||||||
|
P.Declare names es e -> do
|
||||||
|
ts <- traverse infer es
|
||||||
|
let ctx = Map.fromList $ zip names (map (generalize Map.empty) ts)
|
||||||
|
local (Map.union ctx) (infer e)
|
||||||
|
P.Block s e -> do
|
||||||
|
t2 <- infer e
|
||||||
|
return t2
|
||||||
|
P.Process _ _ -> do
|
||||||
|
return TNil
|
||||||
|
P.Pipeln _ _ -> do
|
||||||
|
return TNil
|
||||||
|
P.Str _ -> do
|
||||||
|
return TNil
|
||||||
67
stack.yaml
Normal file
67
stack.yaml
Normal file
@ -0,0 +1,67 @@
|
|||||||
|
# This file was automatically generated by 'stack init'
|
||||||
|
#
|
||||||
|
# Some commonly used options have been documented as comments in this file.
|
||||||
|
# For advanced use and comprehensive documentation of the format, please see:
|
||||||
|
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||||
|
|
||||||
|
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||||
|
# A snapshot resolver dictates the compiler version and the set of packages
|
||||||
|
# to be used for project dependencies. For example:
|
||||||
|
#
|
||||||
|
# resolver: lts-3.5
|
||||||
|
# resolver: nightly-2015-09-21
|
||||||
|
# resolver: ghc-7.10.2
|
||||||
|
#
|
||||||
|
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||||
|
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||||
|
#
|
||||||
|
# resolver: ./custom-snapshot.yaml
|
||||||
|
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||||
|
resolver:
|
||||||
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/21.yaml
|
||||||
|
|
||||||
|
# User packages to be built.
|
||||||
|
# Various formats can be used as shown in the example below.
|
||||||
|
#
|
||||||
|
# packages:
|
||||||
|
# - some-directory
|
||||||
|
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||||
|
# subdirs:
|
||||||
|
# - auto-update
|
||||||
|
# - wai
|
||||||
|
packages:
|
||||||
|
- .
|
||||||
|
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||||
|
# These entries can reference officially published versions as well as
|
||||||
|
# forks / in-progress versions pinned to a git hash. For example:
|
||||||
|
#
|
||||||
|
# extra-deps:
|
||||||
|
# - acme-missiles-0.3
|
||||||
|
# - git: https://github.com/commercialhaskell/stack.git
|
||||||
|
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||||
|
#
|
||||||
|
# extra-deps: []
|
||||||
|
|
||||||
|
# Override default flag values for local packages and extra-deps
|
||||||
|
# flags: {}
|
||||||
|
|
||||||
|
# Extra package databases containing global packages
|
||||||
|
# extra-package-dbs: []
|
||||||
|
|
||||||
|
# Control whether we use the GHC we find on the path
|
||||||
|
# system-ghc: true
|
||||||
|
#
|
||||||
|
# Require a specific version of Stack, using version ranges
|
||||||
|
# require-stack-version: -any # Default
|
||||||
|
# require-stack-version: ">=2.9"
|
||||||
|
#
|
||||||
|
# Override the architecture used by Stack, especially useful on Windows
|
||||||
|
# arch: i386
|
||||||
|
# arch: x86_64
|
||||||
|
#
|
||||||
|
# Extra directories used by Stack for building
|
||||||
|
# extra-include-dirs: [/path/to/dir]
|
||||||
|
# extra-lib-dirs: [/path/to/dir]
|
||||||
|
#
|
||||||
|
# Allow a newer minor version of GHC than the snapshot specifies
|
||||||
|
# compiler-check: newer-minor
|
||||||
13
stack.yaml.lock
Normal file
13
stack.yaml.lock
Normal file
@ -0,0 +1,13 @@
|
|||||||
|
# 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: []
|
||||||
|
snapshots:
|
||||||
|
- completed:
|
||||||
|
sha256: 7d4b649cf368f9076d8aa049aa44efe58950971d105892734e9957b2a26a2186
|
||||||
|
size: 640060
|
||||||
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/21.yaml
|
||||||
|
original:
|
||||||
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/21.yaml
|
||||||
45
test.pll
Normal file
45
test.pll
Normal file
@ -0,0 +1,45 @@
|
|||||||
|
[] , 10 ,10.0, "", process, pipeline, true/false
|
||||||
|
|
||||||
|
if then else
|
||||||
|
|
||||||
|
while
|
||||||
|
|
||||||
|
do while
|
||||||
|
|
||||||
|
skip
|
||||||
|
|
||||||
|
|
||||||
|
declare a := 2 in do {
|
||||||
|
print a;
|
||||||
|
show a;
|
||||||
|
3 + 1
|
||||||
|
}
|
||||||
|
|
||||||
|
declare a := 2 in if true then ... else ...
|
||||||
|
|
||||||
|
declare a:=2 in do {
|
||||||
|
if a then ..
|
||||||
|
}
|
||||||
|
|
||||||
|
declare a:=2; b:=2;c :=2 in do{
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
declare a:=2 in declare b:=2 in declare c:=2 in do {
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
a:[]
|
||||||
|
|
||||||
|
(c:(b:(a:[])))
|
||||||
|
|
||||||
|
|
||||||
|
process A {
|
||||||
|
a :: Number
|
||||||
|
b :: Number
|
||||||
|
}
|
||||||
|
|
||||||
|
pipeline {
|
||||||
|
A >>> B >>> C
|
||||||
|
A >>> (B ||| C) >>> D
|
||||||
|
}
|
||||||
2
test/Spec.hs
Normal file
2
test/Spec.hs
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
main :: IO ()
|
||||||
|
main = putStrLn "Test suite not yet implemented"
|
||||||
Loading…
Reference in New Issue
Block a user