grin-compiler/grin
1
1
Fork 0
mirror of https://github.com/grin-compiler/grin.git synced 2024-09-11 07:25:28 +03:00
Code Issues Projects Releases Wiki Activity

First commit.

Browse Source 
Import grin definitions from csabahruska/partial-evaluation.
This commit is contained in:
Andor Penzes 2017-06-23 22:38:32 +02:00
parent 9861a5dc6b
commit ce7679fa9a
9 changed files with 445 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
README.md Normal file
View File

@ -0,0 +1 @@
# grin

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

4
app/Main.hs Normal file
View File

@ -0,0 +1,4 @@
module Main where
main :: IO ()
main = putStrLn "Grin"

49
grin.cabal Normal file
View File

@ -0,0 +1,49 @@
name: grin
version: 0.1.0.0
-- synopsis:
-- description:
homepage: https://github.com/githubuser/grin#readme
license: GPL3
license-file: LICENSE
author: Andor Penzes, Csaba Hruska
maintainer: andor.penzes@gmail.com
copyright: 2017 Andor Penzes, Csaba Hruska
category: Compiler
build-type: Simple
extra-source-files: README.md
cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules:
Grin
ParseGrin
ReduceGrin
build-depends:
base,
containers,
mtl,
megaparsec
default-language: Haskell2010
executable grin-exe
hs-source-dirs: app
main-is: Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, grin
default-language: Haskell2010
test-suite grin-test
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Spec.hs
build-depends: base
, grin
ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010
source-repository head
type: git
location: https://github.com/andorp/grin

60
src/Grin.hs Normal file
View File

@ -0,0 +1,60 @@
module Grin where
import Data.Map (Map)
type Name = String
type Prog = Map Name Def
data Def = Def Name [Name] Exp
deriving Show
data Exp
= Bind SimpleExp LPat Exp
| Case Val [Alt]
| SExp SimpleExp
deriving Show
data SimpleExp
= App Name [SimpleVal]
| Return Val
| Store Val
| Fetch Name
-- | FetchI Name Int -- fetch node component
| Update Name Val
| Block Exp
deriving Show
type LPat = Val
type SimpleVal = Val
data Val
= TagNode Tag [SimpleVal]
| VarNode Name [SimpleVal]
| ValTag Tag
| Unit
-- simple val
| Lit Lit
| Var Name
-- extra
| Loc Int
| Undefined
deriving (Eq,Show)
data Lit = LFloat Float
deriving (Eq,Show)
data Alt = Alt CPat Exp
deriving Show
data CPat
= NodePat Tag [Name]
| TagPat Tag
| LitPat Lit
deriving Show
data TagType = C | F | P
deriving (Eq,Show)
data Tag = Tag TagType Name Int
deriving (Eq,Show)

114
src/ParseGrin.hs Normal file
View File

@ -0,0 +1,114 @@
{-# LANGUAGE TupleSections #-}
module ParseGrin where
import Control.Applicative (empty)
import Control.Monad (void)
import Text.Megaparsec
import Text.Megaparsec.String
import qualified Text.Megaparsec.Lexer as L
import qualified Data.Set as Set
import Grin
import ReduceGrin
keywords = Set.fromList ["case","of","return","fetch","store","update","if","then","else","do"]
lineComment :: Parser ()
lineComment = L.skipLineComment "--"
blockComment :: Parser ()
blockComment = L.skipBlockComment "{-" "-}"
sc :: Parser ()
sc = L.space (void spaceChar) lineComment blockComment
sc' :: Parser ()
sc' = L.space (void $ oneOf " \t") lineComment blockComment
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc'
symbol = L.symbol sc'
parens = between (symbol "(") (symbol ")")
kw w = lexeme $ string w
op w = L.symbol sc' w
var :: Parser String
var = try $ lexeme ((:) <$> lowerChar <*> many (alphaNumChar <|> oneOf "'_")) >>= \x -> case Set.member x keywords of
True -> fail $ "keyword: " ++ x
False -> return x
con :: Parser String
con = lexeme $ (:) <$> upperChar <*> many (alphaNumChar)
integer = lexeme L.integer
signedInteger = L.signed sc' integer
float = lexeme L.float
signedFloat = L.signed sc' float
-- grin syntax
def = Def <$> try (L.indentGuard sc EQ (unsafePos 1) *> var) <*> many var <* op "=" <*> (L.indentGuard sc GT (unsafePos 1) >>= expr)
expr i = L.indentGuard sc EQ i >>
(\pat e b -> Bind e pat b) <$> try (value <* op "<-") <*> simpleExp i <*> expr i <|>
Case <$ kw "case" <*> value <* kw "of" <*> (L.indentGuard sc GT i >>= some . alternative) <|>
ifThenElse i <|>
try ((\n v e -> Bind (Update n v) Unit e) <$ kw "update" <*> var <*> value <*> expr i) <|>
SExp <$> simpleExp i
ifThenElse i = do
kw "if"
v <- value
kw "then"
t <- (L.indentGuard sc GT i >>= expr)
L.indentGuard sc EQ i
kw "else"
e <- (L.indentGuard sc GT i >>= expr)
return $ Case v [ Alt (TagPat (Tag C "True" 0)) t
, Alt (TagPat (Tag C "False" 0)) e
]
simpleExp i = Return <$ kw "return" <*> value <|>
Store <$ kw "store" <*> value <|>
Fetch <$ kw "fetch" <*> var <|>
Update <$ kw "update" <*> var <*> value <|>
Block <$ kw "do" <*> (L.indentGuard sc GT i >>= expr) <|>
App <$> var <*> some simpleValue
alternative i = Alt <$> try (L.indentGuard sc EQ i *> altPat) <* op "->" <*> (L.indentGuard sc GT i >>= expr)
altPat = parens (NodePat <$> tag <*> many var) <|>
TagPat <$> tag <|>
LitPat <$> literal
tag = Tag C <$ char 'C' <*> con <*> pure 0 <|> -- TODO
Tag F <$ char 'F' <*> var <*> pure 0 <|> -- TODO
Tag P <$ char 'P' <*> (var <|> con) <*> pure 0 -- TODO
simpleValue = Lit <$> literal <|>
Var <$> var
value = Unit <$ op "()" <|>
parens (TagNode <$> tag <*> many simpleValue) <|>
parens (VarNode <$> var <*> many simpleValue) <|>
ValTag <$> tag <|>
simpleValue
literal :: Parser Lit
literal = LFloat . realToFrac <$> try signedFloat <|> LFloat . fromIntegral <$> signedInteger
parseFromFile p file = runParser p file <$> readFile file
eval :: String -> IO ()
eval fname = do
result <- parseFromFile (some def <* sc <* eof) fname
case result of
Left err -> print err
Right e -> do
print e
putStrLn "-------"
print $ reduceFun e "main"

147
src/ReduceGrin.hs Normal file
View File

@ -0,0 +1,147 @@
{-# LANGUAGE LambdaCase #-}
module ReduceGrin (reduceFun) where
import Debug.Trace
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Control.Monad.State
import Control.Monad.Reader
import Grin
data StoreMap
= StoreMap
{ storeMap :: IntMap Val
, storeSize :: !Int
}
emptyStore = StoreMap mempty 0
type Env = Map Name Val
type GrinM = ReaderT Prog (State StoreMap)
bindPatMany :: Env -> [Val] -> [LPat] -> Env
bindPatMany a [] [] = a
bindPatMany a (x:xs) (y:ys) = bindPatMany (bindPat a x y) xs ys
bindPatMany _ x y = error $ "bindPatMany - pattern mismatch: " ++ show (x,y)
bindPat :: Env -> Val -> LPat -> Env
bindPat env v p = case p of
Var n -> case v of
ValTag{} -> Map.insert n v env
Unit -> Map.insert n v env
Lit{} -> Map.insert n v env
Loc{} -> Map.insert n v env
Undefined -> Map.insert n v env
_ -> {-trace ("bindPat - illegal value: " ++ show v) $ -}Map.insert n v env
_ -> error $ "bindPat - illegal value: " ++ show v
TagNode t l -> case v of
TagNode vt vl | vt == t -> bindPatMany env vl l
_ -> error $ "bindPat - illegal value for TagNode: " ++ show v
VarNode n l -> case v of
TagNode vt vl -> bindPatMany (Map.insert n (ValTag vt) env) vl l
_ -> error $ "bindPat - illegal value for TagNode: " ++ show v
_ | p == v -> env
| otherwise -> error $ "bindPat - pattern mismatch" ++ show (v,p)
lookupEnv :: Name -> Env -> Val
lookupEnv n env = Map.findWithDefault (error $ "missing variable: " ++ n) n env
lookupStore :: Int -> StoreMap -> Val
lookupStore i s = IntMap.findWithDefault (error $ "missing location: " ++ show i) i $ storeMap s
evalVal :: Env -> Val -> Val
evalVal env = \case
v@Lit{} -> v
Var n -> lookupEnv n env
TagNode t a -> TagNode t $ map (evalVal env) a
VarNode n a -> case lookupEnv n env of
Var n -> VarNode n $ map (evalVal env) a
ValTag t -> TagNode t $ map (evalVal env) a
x -> error $ "evalVal - invalid VarNode tag: " ++ show x
v@ValTag{} -> v
v@Unit -> v
v@Loc{} -> v
x -> error $ "evalVal: " ++ show x
evalSimpleExp :: Env -> SimpleExp -> GrinM Val
evalSimpleExp env = \case
App n a -> {-# SCC eSE_App #-}do
let args = map (evalVal env) a
go a [] [] = a
go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys
go _ x y = error $ "invalid pattern for function: " ++ show (n,x,y)
case n of
"add" -> primAdd args
"mul" -> primMul args
"intPrint" -> primIntPrint args
"intGT" -> primIntGT args
"intAdd" -> primAdd args
_ -> do
Def _ vars body <- reader $ Map.findWithDefault (error $ "unknown function: " ++ n) n
evalExp (go env vars args) body
Return v -> {-# SCC eSE_Return #-}return $ evalVal env v
Store v -> {-# SCC eSE_Store #-}do
l <- {-# SCC eSE_Store_size #-}gets storeSize
let v' = evalVal env v
modify' ({-# SCC eSE_Store_insert #-}\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) (s+1))
return $ Loc l
Fetch n -> {-# SCC eSE_Fetch #-}case lookupEnv n env of
Loc l -> gets $ lookupStore l
x -> error $ "evalSimpleExp - Fetch expected location, got: " ++ show x
-- | FetchI Name Int -- fetch node component
Update n v -> {-# SCC eSE_Update #-}do
let v' = evalVal env v
case lookupEnv n env of
Loc l -> get >>= \(StoreMap m _) -> case IntMap.member l m of
False -> error $ "evalSimpleExp - Update unknown location: " ++ show l
True -> modify' (\(StoreMap m s) -> StoreMap (IntMap.insert l v' m) s) >> return Unit
x -> error $ "evalSimpleExp - Update expected location, got: " ++ show x
Block a -> {-# SCC eSE_Block #-}evalExp env a
x -> error $ "evalSimpleExp: " ++ show x
evalExp :: Env -> Exp -> GrinM Val
evalExp env = \case
Bind op pat exp -> evalSimpleExp env op >>= \v -> evalExp (bindPat env v pat) exp
Case v alts -> case evalVal env v of
TagNode t l -> let (vars,exp) = head $ [(b,exp) | Alt (NodePat a b) exp <- alts, a == t] ++ error ("evalExp - missing Case Node alternative for: " ++ show t)
go a [] [] = a
go a (x:xs) (y:ys) = go (Map.insert x y a) xs ys
go _ x y = error $ "invalid pattern and constructor: " ++ show (t,x,y)
in evalExp (go env vars l) exp
ValTag t -> evalExp env $ head $ [exp | Alt (TagPat a) exp <- alts, a == t] ++ error ("evalExp - missing Case Tag alternative for: " ++ show t)
Lit l -> evalExp env $ head $ [exp | Alt (LitPat a) exp <- alts, a == l] ++ error ("evalExp - missing Case Lit alternative for: " ++ show l)
x -> error $ "evalExp - invalid Case dispatch value: " ++ show x
SExp exp -> evalSimpleExp env exp
x -> error $ "evalExp: " ++ show x
-- primitive functions
primIntGT [Lit (LFloat a), Lit (LFloat b)] = return $ ValTag $ Tag C (if a > b then "True" else "False") 0
primIntGT x = error $ "primIntGT - invalid arguments: " ++ show x
primIntPrint [Lit (LFloat a)] = return $ Lit $ LFloat $ a
primIntPrint x = error $ "primIntPrint - invalid arguments: " ++ show x
primAdd [Lit (LFloat a), Lit (LFloat b)] = return $ Lit $ LFloat $ a + b
primAdd x = error $ "primAdd - invalid arguments: " ++ show x
primMul [Lit (LFloat a), Lit (LFloat b)] = return $ Lit $ LFloat $ a * b
primMul x = error $ "primMul - invalid arguments: " ++ show x
reduce :: Exp -> Val
reduce e = evalState (runReaderT (evalExp mempty e) mempty) emptyStore
reduceFun :: [Def] -> Name -> Val
reduceFun l n = evalState (runReaderT (evalExp mempty e) m) emptyStore where
m = Map.fromList [(n,d) | d@(Def n _ _) <- l]
e = case Map.lookup n m of
Nothing -> error $ "missing function: " ++ n
Just (Def _ [] a) -> a
_ -> error $ "function " ++ n ++ " has arguments"
sadd = App "add" [Lit $ LFloat 3, Lit $ LFloat 2]
test = SExp sadd
test2 = Bind sadd (Var "a") $ SExp $ App "mul" [Var "a", Var "a"]

66
stack.yaml Normal file
View File

@ -0,0 +1,66 @@
# 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:
# http://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
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: lts-8.20
# 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
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- '.'
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
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: ">=1.2"
#
# 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

2
test/Spec.hs Normal file
View File

@ -0,0 +1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"