Happy parse lex #1
3
docs/src/commentary/layout-lexing.rst
Normal file
3
docs/src/commentary/layout-lexing.rst
Normal file
@@ -0,0 +1,3 @@
|
|||||||
|
Parsing and the Layout System
|
||||||
|
=============================
|
||||||
|
|
||||||
@@ -1,3 +0,0 @@
|
|||||||
Parser Combinators
|
|
||||||
==================
|
|
||||||
|
|
||||||
@@ -22,11 +22,13 @@ library
|
|||||||
, TIM
|
, TIM
|
||||||
other-modules: Data.Heap
|
other-modules: Data.Heap
|
||||||
, Data.Pretty
|
, Data.Pretty
|
||||||
, Control.Parser
|
|
||||||
, Core.Syntax
|
, Core.Syntax
|
||||||
, Core.Parse
|
, Core.Parse
|
||||||
, Core.Lex
|
|
||||||
, Core.TH
|
, Core.TH
|
||||||
|
, Core.Examples
|
||||||
|
, Core.Lex
|
||||||
|
|
||||||
|
build-tool-depends: happy:happy, alex:alex
|
||||||
|
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends: base ^>=4.18.0.0
|
build-depends: base ^>=4.18.0.0
|
||||||
@@ -34,6 +36,8 @@ library
|
|||||||
, microlens
|
, microlens
|
||||||
, microlens-th
|
, microlens-th
|
||||||
, template-haskell
|
, template-haskell
|
||||||
|
-- required for happy
|
||||||
|
, array
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: GHC2021
|
default-language: GHC2021
|
||||||
|
|
||||||
|
|||||||
@@ -1,106 +0,0 @@
|
|||||||
{-|
|
|
||||||
Module : Control.Parser
|
|
||||||
Description : Parser combinators
|
|
||||||
|
|
||||||
This module implements an interface for parser *types*, used in lexical analysis
|
|
||||||
and parsing. For the implementation of the rlp language's parser, see 'Parse'.
|
|
||||||
-}
|
|
||||||
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE BlockArguments, LambdaCase #-}
|
|
||||||
module Control.Parser
|
|
||||||
( ParserT
|
|
||||||
, runParserT
|
|
||||||
|
|
||||||
, satisfy
|
|
||||||
, char
|
|
||||||
, spaces
|
|
||||||
, surround
|
|
||||||
, string
|
|
||||||
, match
|
|
||||||
, termMany
|
|
||||||
, sepSome
|
|
||||||
|
|
||||||
-- * Control.Applicative re-exports
|
|
||||||
, (<|>)
|
|
||||||
, many
|
|
||||||
, some
|
|
||||||
, empty
|
|
||||||
)
|
|
||||||
where
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Arrow ((***))
|
|
||||||
import Control.Monad
|
|
||||||
import Data.Char
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
newtype ParserT i m o = ParserT { runParserT :: i -> m (i, o) }
|
|
||||||
deriving (Functor)
|
|
||||||
|
|
||||||
instance (Monad m) => Applicative (ParserT i m) where
|
|
||||||
pure a = ParserT \i -> pure (i, a)
|
|
||||||
|
|
||||||
m <*> k = ParserT \i -> do
|
|
||||||
(i',f) <- runParserT m i
|
|
||||||
fmap (id *** f) $ runParserT k i'
|
|
||||||
|
|
||||||
instance (MonadPlus m) => Alternative (ParserT i m) where
|
|
||||||
empty = ParserT $ const empty
|
|
||||||
|
|
||||||
ParserT m <|> ParserT k = ParserT $ \i ->
|
|
||||||
m i <|> k i
|
|
||||||
|
|
||||||
instance (MonadPlus m) => MonadPlus (ParserT i m)
|
|
||||||
|
|
||||||
instance (Monad m) => Monad (ParserT i m) where
|
|
||||||
m >>= k = ParserT $ \i -> do
|
|
||||||
(i',a) <- runParserT m i
|
|
||||||
runParserT (k a) i'
|
|
||||||
|
|
||||||
instance (MonadFail m) => MonadFail (ParserT i m) where
|
|
||||||
fail s = ParserT $ \i -> fail s
|
|
||||||
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
eof :: (MonadPlus m) => ParserT [a] m ()
|
|
||||||
eof = ParserT $ \case
|
|
||||||
[] -> pure ([], ())
|
|
||||||
_ -> empty
|
|
||||||
|
|
||||||
-- TODO: generalise to non-lists
|
|
||||||
satisfy :: (MonadPlus m) => (a -> Bool) -> ParserT [a] m a
|
|
||||||
satisfy p = ParserT $ \case
|
|
||||||
(x:xs) | p x -> pure (xs,x)
|
|
||||||
_ -> empty
|
|
||||||
|
|
||||||
match :: (MonadPlus m) => (a -> Maybe b) -> ParserT [a] m b
|
|
||||||
match f = ParserT $ \case
|
|
||||||
(x:xs) -> case f x of
|
|
||||||
Just b -> pure (xs,b)
|
|
||||||
Nothing -> empty
|
|
||||||
[] -> empty
|
|
||||||
|
|
||||||
termMany :: (MonadPlus m) => ParserT i m t -> ParserT i m o -> ParserT i m [o]
|
|
||||||
termMany t a = many (a <* t)
|
|
||||||
|
|
||||||
sepSome :: (MonadPlus m) => ParserT i m t -> ParserT i m o -> ParserT i m [o]
|
|
||||||
sepSome s a = (:) <$> a <*> many (s *> a)
|
|
||||||
|
|
||||||
char :: (MonadPlus m, Eq a) => a -> ParserT [a] m a
|
|
||||||
char c = satisfy (==c)
|
|
||||||
|
|
||||||
string :: (MonadPlus m, Eq a) => [a] -> ParserT [a] m [a]
|
|
||||||
string s = sequenceA $ char <$> s
|
|
||||||
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
surround :: (MonadPlus m)
|
|
||||||
=> ParserT i m l
|
|
||||||
-> ParserT i m r
|
|
||||||
-> ParserT i m c
|
|
||||||
-> ParserT i m c
|
|
||||||
surround l r c = l *> c <* r
|
|
||||||
|
|
||||||
spaces :: (MonadPlus m) => ParserT String m Int
|
|
||||||
spaces = length <$> many (satisfy (==' '))
|
|
||||||
|
|
||||||
22
src/Core/Examples.hs
Normal file
22
src/Core/Examples.hs
Normal file
@@ -0,0 +1,22 @@
|
|||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
module Core.Examples where
|
||||||
|
----------------------------------------------------------------------------------
|
||||||
|
import Core.Syntax
|
||||||
|
import Core.TH
|
||||||
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
{-
|
||||||
|
|
||||||
|
letrecExample :: Program
|
||||||
|
letrecExample = [core|
|
||||||
|
pair x y f = f x y;
|
||||||
|
fst p = p k;
|
||||||
|
snd p = p k1;
|
||||||
|
f x y = letrec
|
||||||
|
{ a = pair x b;
|
||||||
|
; b = pair y a
|
||||||
|
} in fst (snd (snd (snd a)));
|
||||||
|
main = f 3 4;
|
||||||
|
|]
|
||||||
|
|
||||||
|
-}
|
||||||
141
src/Core/Lex.hs
141
src/Core/Lex.hs
@@ -1,141 +0,0 @@
|
|||||||
{-|
|
|
||||||
Module : Core.Lex
|
|
||||||
Description : Core language lexer
|
|
||||||
-}
|
|
||||||
module Core.Lex
|
|
||||||
( CoreToken(..)
|
|
||||||
, Result(..)
|
|
||||||
, lexCore
|
|
||||||
)
|
|
||||||
where
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
import Control.Parser
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad
|
|
||||||
import Data.Char
|
|
||||||
import Data.Functor
|
|
||||||
import Core.Syntax (Name)
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
type CoreLexer = ParserT String Result
|
|
||||||
|
|
||||||
data Result a = Success a
|
|
||||||
| Error String Int Int
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
-- TODO: whitespace-sensitive layout
|
|
||||||
data CoreToken = TokLitInt Int
|
|
||||||
| TokEquals
|
|
||||||
| TokLBrace
|
|
||||||
| TokRBrace
|
|
||||||
| TokSemicolon
|
|
||||||
| TokLParen
|
|
||||||
| TokRParen
|
|
||||||
| TokLambda
|
|
||||||
| TokArrow
|
|
||||||
| TokCase
|
|
||||||
| TokOf
|
|
||||||
| TokLet
|
|
||||||
| TokLetRec
|
|
||||||
| TokIn
|
|
||||||
| TokCName Name
|
|
||||||
| TokName Name
|
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
instance Functor Result where
|
|
||||||
fmap f (Success a) = Success (f a)
|
|
||||||
fmap _ (Error s l c) = Error s l c
|
|
||||||
|
|
||||||
instance Foldable Result where
|
|
||||||
foldr f z (Success a) = a `f` z
|
|
||||||
foldr _ z (Error _ _ _) = z
|
|
||||||
|
|
||||||
instance Traversable Result where
|
|
||||||
traverse k (Success a) = fmap Success (k a)
|
|
||||||
traverse _ (Error s l c) = pure $ Error s l c
|
|
||||||
|
|
||||||
instance Applicative Result where
|
|
||||||
pure = Success
|
|
||||||
|
|
||||||
liftA2 f (Success a) (Success b) = Success $ f a b
|
|
||||||
liftA2 _ (Error s l c) _ = Error s l c
|
|
||||||
liftA2 _ _ (Error s l c) = Error s l c
|
|
||||||
|
|
||||||
instance Alternative Result where
|
|
||||||
empty = Error "some error! this is a temporary system lol" 0 0
|
|
||||||
|
|
||||||
(Success a) <|> _ = Success a
|
|
||||||
_ <|> b = b
|
|
||||||
|
|
||||||
instance Monad Result where
|
|
||||||
Success a >>= k = k a
|
|
||||||
Error s l c >>= _ = Error s l c
|
|
||||||
|
|
||||||
instance MonadPlus Result
|
|
||||||
|
|
||||||
instance MonadFail Result where
|
|
||||||
fail s = Error s 0 0
|
|
||||||
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
lexCore :: String -> Result [CoreToken]
|
|
||||||
lexCore = fmap snd . runParserT (many (token <* spaces))
|
|
||||||
|
|
||||||
token :: CoreLexer CoreToken
|
|
||||||
token = litInt
|
|
||||||
<|> lbrace
|
|
||||||
<|> rbrace
|
|
||||||
<|> semicolon
|
|
||||||
<|> lparen
|
|
||||||
<|> rparen
|
|
||||||
<|> equals
|
|
||||||
<|> lambda
|
|
||||||
<|> arrow
|
|
||||||
<|> _case
|
|
||||||
<|> _of
|
|
||||||
<|> letrec
|
|
||||||
<|> _let
|
|
||||||
<|> _in
|
|
||||||
<|> cName
|
|
||||||
<|> name
|
|
||||||
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
litInt, equals, lparen, rparen, lambda,
|
|
||||||
arrow, _case, _of, _let, letrec, _in, cName, name :: CoreLexer CoreToken
|
|
||||||
|
|
||||||
litInt = TokLitInt . value <$> some (satisfy isDigit)
|
|
||||||
where
|
|
||||||
value = foldl (\acc a -> 10*acc + digitToInt a) 0
|
|
||||||
|
|
||||||
semicolon = (semis <|> nls) $> TokSemicolon
|
|
||||||
where
|
|
||||||
nls = head <$> some (char '\n')
|
|
||||||
semis = char ';' <* many (char '\n')
|
|
||||||
equals = char '=' $> TokEquals
|
|
||||||
lbrace = char '{' $> TokLBrace
|
|
||||||
rbrace = char '}' $> TokRBrace
|
|
||||||
lparen = char '(' $> TokLParen
|
|
||||||
rparen = char ')' $> TokRParen
|
|
||||||
lambda = (char '\\' <|> char 'λ') $> TokLambda
|
|
||||||
arrow = string "->" $> TokArrow
|
|
||||||
_case = string "case" $> TokCase
|
|
||||||
_of = string "of" $> TokOf
|
|
||||||
_let = string "let" $> TokLet
|
|
||||||
letrec = string "letrec" $> TokLetRec
|
|
||||||
_in = string "in" $> TokIn
|
|
||||||
|
|
||||||
cName = TokCName <$> ((:) <$> cNameHead <*> properNameTail)
|
|
||||||
where cNameHead = satisfy isUpper
|
|
||||||
|
|
||||||
name = some (satisfy p) <&> TokName
|
|
||||||
where p c = not (isSpace c) && c `notElem` ";{}()"
|
|
||||||
|
|
||||||
properName :: CoreLexer Name
|
|
||||||
properName = (:) <$> nameHead <*> properNameTail
|
|
||||||
where nameHead = satisfy isLetter
|
|
||||||
|
|
||||||
properNameTail :: CoreLexer Name
|
|
||||||
properNameTail = many . satisfy $ \c ->
|
|
||||||
isLetter c || isDigit c || c == '_'
|
|
||||||
|
|
||||||
107
src/Core/Lex.x
Normal file
107
src/Core/Lex.x
Normal file
@@ -0,0 +1,107 @@
|
|||||||
|
{
|
||||||
|
module Core.Lex
|
||||||
|
( CoreToken(..)
|
||||||
|
, lexCore
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Core.Syntax
|
||||||
|
import Lens.Micro
|
||||||
|
}
|
||||||
|
|
||||||
|
%wrapper "monadUserState"
|
||||||
|
|
||||||
|
$digit = 0-9
|
||||||
|
$alpha = [a-zA-Z]
|
||||||
|
|
||||||
|
$special = [\*\^\%\$#@!\<\>\+\-\=\/&\|\\\.]
|
||||||
|
|
||||||
|
$nameTail = [ $alpha $digit \_ \' ]
|
||||||
|
|
||||||
|
rlp :-
|
||||||
|
|
||||||
|
-- tokens :-
|
||||||
|
-- $white+ ;
|
||||||
|
-- "--" ~$special .* ;
|
||||||
|
-- module { const TokenModule }
|
||||||
|
-- where { const TokenWhere }
|
||||||
|
-- let { const TokenLet }
|
||||||
|
-- letrec { const TokenLetrec }
|
||||||
|
-- in { const TokenIn }
|
||||||
|
-- case { const TokenCase }
|
||||||
|
-- of { const TokenOf }
|
||||||
|
-- $digit+ { TokenLitInt . read @Int }
|
||||||
|
-- "," { const TokenComma }
|
||||||
|
-- "(" { const TokenLParen }
|
||||||
|
-- ")" { const TokenRParen }
|
||||||
|
-- "{" { const TokenLBrace }
|
||||||
|
-- "}" { const TokenRBrace }
|
||||||
|
-- "\\" { const TokenLambda }
|
||||||
|
-- "λ" { const TokenLambda }
|
||||||
|
-- ";" { const TokenSemicolon }
|
||||||
|
-- $special+ { lexSym }
|
||||||
|
-- $alpha $nameTail* { TokenName }
|
||||||
|
|
||||||
|
<0> \n {begin bol}
|
||||||
|
|
||||||
|
<bol>
|
||||||
|
{
|
||||||
|
\n ;
|
||||||
|
() { doBOL }
|
||||||
|
}
|
||||||
|
|
||||||
|
{
|
||||||
|
|
||||||
|
data CoreToken = TokenLet
|
||||||
|
| TokenLetrec
|
||||||
|
| TokenIn
|
||||||
|
| TokenModule
|
||||||
|
| TokenWhere
|
||||||
|
| TokenComma
|
||||||
|
| TokenCase
|
||||||
|
| TokenOf
|
||||||
|
| TokenLambda
|
||||||
|
| TokenArrow
|
||||||
|
| TokenLitInt Int
|
||||||
|
| TokenName Name
|
||||||
|
| TokenSym Name
|
||||||
|
| TokenEquals
|
||||||
|
| TokenLParen
|
||||||
|
| TokenRParen
|
||||||
|
| TokenLBrace
|
||||||
|
| TokenRBrace
|
||||||
|
| TokenSemicolon
|
||||||
|
deriving Show
|
||||||
|
|
||||||
|
data LayoutContext = NoLayout
|
||||||
|
| Layout Int
|
||||||
|
|
||||||
|
data AlexUserState = AlexUserState
|
||||||
|
{ _ausContext :: [LayoutContext]
|
||||||
|
}
|
||||||
|
|
||||||
|
ausContext :: Lens' AlexUserState [LayoutContext]
|
||||||
|
ausContext = lens _ausContext (\s b -> s { _ausContext = b })
|
||||||
|
|
||||||
|
alexInitUserState = AlexUserState
|
||||||
|
{ _ausContext = []
|
||||||
|
}
|
||||||
|
|
||||||
|
-- lexCore :: String -> [CoreToken]
|
||||||
|
lexCore = alexScanTokens
|
||||||
|
|
||||||
|
-- lexSym :: String -> CoreToken
|
||||||
|
-- lexSym "=" = TokenEquals
|
||||||
|
-- lexSym "\\" = TokenLambda
|
||||||
|
-- lexSym "->" = TokenArrow
|
||||||
|
-- lexSym s = TokenSym s
|
||||||
|
|
||||||
|
lexSym = undefined
|
||||||
|
|
||||||
|
doBOL = undefined
|
||||||
|
|
||||||
|
alexEOF = undefined
|
||||||
|
|
||||||
|
alexScanTokens = undefined
|
||||||
|
|
||||||
|
}
|
||||||
@@ -1,99 +0,0 @@
|
|||||||
{-# LANGUAGE LambdaCase, BlockArguments #-}
|
|
||||||
module Core.Parse
|
|
||||||
( parseCore
|
|
||||||
, parseCoreExpr
|
|
||||||
)
|
|
||||||
where
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
import Control.Parser
|
|
||||||
import Data.Functor ((<&>), ($>))
|
|
||||||
import Core.Lex
|
|
||||||
import Core.Syntax
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
type CoreParser = ParserT [CoreToken] Result
|
|
||||||
|
|
||||||
parseCore :: [CoreToken] -> Result Program
|
|
||||||
parseCore = fmap snd . runParserT program
|
|
||||||
|
|
||||||
parseCoreExpr :: [CoreToken] -> Result Expr
|
|
||||||
parseCoreExpr = fmap snd . runParserT expr
|
|
||||||
|
|
||||||
program :: CoreParser Program
|
|
||||||
program = Program <$> termMany (char TokSemicolon) scdef
|
|
||||||
|
|
||||||
scdef :: CoreParser ScDef
|
|
||||||
scdef = ScDef <$> f <*> (xs <* eq) <*> body
|
|
||||||
where
|
|
||||||
f = name
|
|
||||||
xs = many name
|
|
||||||
eq = char TokEquals
|
|
||||||
body = expr
|
|
||||||
|
|
||||||
expr :: CoreParser Expr
|
|
||||||
expr = letE
|
|
||||||
<|> app
|
|
||||||
<|> lam
|
|
||||||
<|> atom
|
|
||||||
|
|
||||||
atom :: CoreParser Expr
|
|
||||||
atom = var
|
|
||||||
<|> con
|
|
||||||
<|> parenE
|
|
||||||
<|> lit
|
|
||||||
where
|
|
||||||
var = Var <$> name
|
|
||||||
parenE = surround (char TokLParen) (char TokRParen) expr
|
|
||||||
lit = IntE <$> litInt
|
|
||||||
|
|
||||||
lam :: CoreParser Expr
|
|
||||||
lam = Lam <$> (l *> bs) <*> (arrow *> expr)
|
|
||||||
where
|
|
||||||
l = char TokLambda
|
|
||||||
arrow = char TokArrow
|
|
||||||
bs = some name
|
|
||||||
|
|
||||||
app :: CoreParser Expr
|
|
||||||
app = foldl App <$> atom <*> some atom
|
|
||||||
|
|
||||||
con :: CoreParser Expr
|
|
||||||
con = pack *> (Con <$> (l *> tag) <*> (arity <* r))
|
|
||||||
where
|
|
||||||
l = char TokLBrace
|
|
||||||
r = char TokRBrace
|
|
||||||
tag = litInt
|
|
||||||
arity = litInt
|
|
||||||
pack = match \case
|
|
||||||
TokCName "Pack" -> Just ()
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
letE :: CoreParser Expr
|
|
||||||
letE = Let <$> word <*> defs <*> (char TokIn *> expr)
|
|
||||||
where
|
|
||||||
word = char TokLet $> NonRec
|
|
||||||
<|> char TokLetRec $> Rec
|
|
||||||
defs = surround (char TokLBrace) (char TokRBrace) bindings
|
|
||||||
|
|
||||||
bindings :: CoreParser [Binding]
|
|
||||||
bindings = sepSome (char TokSemicolon) binding
|
|
||||||
|
|
||||||
binding :: CoreParser Binding
|
|
||||||
binding = Binding <$> name <*> (char TokEquals *> expr)
|
|
||||||
|
|
||||||
----------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
name :: CoreParser Name
|
|
||||||
name = match \case
|
|
||||||
TokName n -> Just n
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
cName :: CoreParser Name
|
|
||||||
cName = match \case
|
|
||||||
TokCName n -> Just n
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
litInt :: CoreParser Int
|
|
||||||
litInt = match \case
|
|
||||||
TokLitInt n -> Just n
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
82
src/Core/Parse.y
Normal file
82
src/Core/Parse.y
Normal file
@@ -0,0 +1,82 @@
|
|||||||
|
{
|
||||||
|
module Core.Parse
|
||||||
|
( parseCore
|
||||||
|
-- , parseCoreExpr
|
||||||
|
, module Core.Lex -- temp convenience
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Data.Foldable (foldl')
|
||||||
|
import Core.Syntax
|
||||||
|
import Core.Lex
|
||||||
|
}
|
||||||
|
|
||||||
|
%name parseCore
|
||||||
|
%name parseCoreExpr Expr
|
||||||
|
%tokentype { CoreToken }
|
||||||
|
%error { parseError }
|
||||||
|
|
||||||
|
%token
|
||||||
|
let { TokenLet }
|
||||||
|
letrec { TokenLetrec }
|
||||||
|
module { TokenModule }
|
||||||
|
where { TokenWhere }
|
||||||
|
',' { TokenComma }
|
||||||
|
in { TokenIn }
|
||||||
|
litint { TokenLitInt $$ }
|
||||||
|
name { TokenName $$ }
|
||||||
|
sym { TokenSym $$ }
|
||||||
|
'λ' { TokenLambda }
|
||||||
|
'->' { TokenArrow }
|
||||||
|
'=' { TokenEquals }
|
||||||
|
'(' { TokenLParen }
|
||||||
|
')' { TokenRParen }
|
||||||
|
'{' { TokenLBrace }
|
||||||
|
'}' { TokenRBrace }
|
||||||
|
';' { TokenSemicolon }
|
||||||
|
|
||||||
|
%%
|
||||||
|
|
||||||
|
ExportList :: { [Name] }
|
||||||
|
ExportList : '(' Exports ')' { $2 }
|
||||||
|
|
||||||
|
Exports :: { [Name] }
|
||||||
|
Exports : Var ',' Exports { $1 : $3 }
|
||||||
|
| Var { [$1] }
|
||||||
|
|
||||||
|
Expr :: { Expr }
|
||||||
|
Expr : let Bindings in Expr { Let NonRec $2 $4 }
|
||||||
|
| letrec Bindings in Expr { Let Rec $2 $4 }
|
||||||
|
| 'λ' Binders '->' Expr { Lam $2 $4 }
|
||||||
|
| Application { $1 }
|
||||||
|
| Expr1 { $1 }
|
||||||
|
|
||||||
|
Binders :: { [Name] }
|
||||||
|
Binders : Var Binders { $1 : $2 }
|
||||||
|
| Var { [$1] }
|
||||||
|
|
||||||
|
Application :: { Expr }
|
||||||
|
Application : Expr1 AppArgs { foldl' App $1 $2 }
|
||||||
|
|
||||||
|
-- TODO: Application can probably be written as a single rule, without AppArgs
|
||||||
|
AppArgs :: { [Expr] }
|
||||||
|
AppArgs : Expr1 AppArgs { $1 : $2 }
|
||||||
|
| Expr1 { [$1] }
|
||||||
|
|
||||||
|
Expr1 :: { Expr }
|
||||||
|
Expr1 : litint { IntE $1 }
|
||||||
|
| Var { Var $1 }
|
||||||
|
| '(' Expr ')' { $2 }
|
||||||
|
|
||||||
|
Var :: { Name }
|
||||||
|
Var : '(' sym ')' { $2 }
|
||||||
|
| name { $1 }
|
||||||
|
|
||||||
|
Bindings :: { [Binding] }
|
||||||
|
Bindings : Var '=' Expr { [$1 := $3] }
|
||||||
|
|
||||||
|
{
|
||||||
|
parseError :: [CoreToken] -> a
|
||||||
|
parseError _ = error "fuuckk!"
|
||||||
|
}
|
||||||
|
|
||||||
@@ -8,11 +8,13 @@ module Core.Syntax
|
|||||||
, Alter(..)
|
, Alter(..)
|
||||||
, Name
|
, Name
|
||||||
, ScDef(..)
|
, ScDef(..)
|
||||||
|
, Module(..)
|
||||||
, Program(..)
|
, Program(..)
|
||||||
, corePrelude
|
, corePrelude
|
||||||
, bindersOf
|
, bindersOf
|
||||||
, rhssOf
|
, rhssOf
|
||||||
, isAtomic
|
, isAtomic
|
||||||
|
, insertModule
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
@@ -56,6 +58,9 @@ type Name = String
|
|||||||
data ScDef = ScDef Name [Name] Expr
|
data ScDef = ScDef Name [Name] Expr
|
||||||
deriving (Show, Lift)
|
deriving (Show, Lift)
|
||||||
|
|
||||||
|
data Module = Module (Maybe (Name, [Name])) Program
|
||||||
|
deriving (Show, Lift)
|
||||||
|
|
||||||
newtype Program = Program [ScDef]
|
newtype Program = Program [ScDef]
|
||||||
deriving (Show, Lift)
|
deriving (Show, Lift)
|
||||||
|
|
||||||
@@ -64,6 +69,15 @@ instance IsString Expr where
|
|||||||
|
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
instance Pretty Program where
|
||||||
|
-- TODO: module header
|
||||||
|
prettyPrec (Program ss) _ = mconcat $ intersperse "\n\n" $ fmap pretty ss
|
||||||
|
|
||||||
|
instance Pretty ScDef where
|
||||||
|
prettyPrec (ScDef n as e) _ =
|
||||||
|
mconcat (intersperse " " $ fmap IStr (n:as))
|
||||||
|
<> " = " <> pretty e <> IBreak
|
||||||
|
|
||||||
instance Pretty Expr where
|
instance Pretty Expr where
|
||||||
prettyPrec (Var k) = withPrec maxBound $ IStr k
|
prettyPrec (Var k) = withPrec maxBound $ IStr k
|
||||||
prettyPrec (IntE n) = withPrec maxBound $ iShow n
|
prettyPrec (IntE n) = withPrec maxBound $ iShow n
|
||||||
@@ -106,7 +120,7 @@ instance Pretty Binding where
|
|||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
instance Semigroup Program where
|
instance Semigroup Program where
|
||||||
(<>) = coerce $ (++) @ScDef
|
(<>) = coerce $ (<>) @[ScDef]
|
||||||
|
|
||||||
instance Monoid Program where
|
instance Monoid Program where
|
||||||
mempty = Program []
|
mempty = Program []
|
||||||
@@ -125,15 +139,19 @@ isAtomic _ = False
|
|||||||
|
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
corePrelude :: Program
|
corePrelude :: Module
|
||||||
corePrelude = Program
|
corePrelude = Module (Just ("Prelude", [])) $ Program
|
||||||
[ ScDef "id" ["x"] (Var "x")
|
[ ScDef "id" ["x"] (Var "x")
|
||||||
, ScDef "K" ["x", "y"] (Var "x")
|
, ScDef "k" ["x", "y"] (Var "x")
|
||||||
, ScDef "K1" ["x", "y"] (Var "y")
|
, ScDef "k1" ["x", "y"] (Var "y")
|
||||||
, ScDef "S" ["f", "g", "x"] (Var "f" :$ Var "x" :$ (Var "g" :$ Var "x"))
|
, ScDef "succ" ["f", "g", "x"] (Var "f" :$ Var "x" :$ (Var "g" :$ Var "x"))
|
||||||
, ScDef "compose" ["f", "g", "x"] (Var "f" :$ (Var "g" :$ Var "x"))
|
, ScDef "compose" ["f", "g", "x"] (Var "f" :$ (Var "g" :$ Var "x"))
|
||||||
, ScDef "twice" ["f", "x"] (Var "f" :$ (Var "f" :$ Var "x"))
|
, ScDef "twice" ["f", "x"] (Var "f" :$ (Var "f" :$ Var "x"))
|
||||||
, ScDef "False" [] $ Con 0 0
|
, ScDef "False" [] $ Con 0 0
|
||||||
, ScDef "True" [] $ Con 1 0
|
, ScDef "True" [] $ Con 1 0
|
||||||
]
|
]
|
||||||
|
|
||||||
|
-- TODO: export list awareness
|
||||||
|
insertModule :: Module -> Program -> Program
|
||||||
|
insertModule (Module _ m) p = p <> m
|
||||||
|
|
||||||
|
|||||||
@@ -27,13 +27,16 @@ coreExpr = QuasiQuoter
|
|||||||
, quoteDec = error "core quasiquotes may only be used in expressions"
|
, quoteDec = error "core quasiquotes may only be used in expressions"
|
||||||
}
|
}
|
||||||
|
|
||||||
qCore :: String -> Q Exp
|
qCore = undefined
|
||||||
qCore s = case lexCore s >>= parseCore of
|
qCoreExpr = undefined
|
||||||
Success a -> lift a
|
|
||||||
Error e _ _ -> error e
|
|
||||||
|
|
||||||
qCoreExpr :: String -> Q Exp
|
-- qCore :: String -> Q Exp
|
||||||
qCoreExpr s = case lexCore s >>= parseCoreExpr of
|
-- qCore s = case lexCore s >>= parseCore of
|
||||||
Success a -> lift a
|
-- Success a -> lift a
|
||||||
Error e _ _ -> error e
|
-- Error e _ _ -> error e
|
||||||
|
|
||||||
|
-- qCoreExpr :: String -> Q Exp
|
||||||
|
-- qCoreExpr s = case lexCore s >>= parseCoreExpr of
|
||||||
|
-- Success a -> lift a
|
||||||
|
-- Error e _ _ -> error e
|
||||||
|
|
||||||
|
|||||||
150
src/TIM.hs
150
src/TIM.hs
@@ -71,7 +71,7 @@ compile prog = Just $ TiState s d h g stats
|
|||||||
s = [mainAddr]
|
s = [mainAddr]
|
||||||
d = []
|
d = []
|
||||||
(h,g) = buildInitialHeap defs
|
(h,g) = buildInitialHeap defs
|
||||||
defs = prog <> corePrelude
|
defs = insertModule corePrelude prog
|
||||||
stats = Stats 0 0 0
|
stats = Stats 0 0 0
|
||||||
|
|
||||||
mainAddr = fromJust $ lookup "main" g
|
mainAddr = fromJust $ lookup "main" g
|
||||||
@@ -422,91 +422,91 @@ hdbgProg p hio = do
|
|||||||
TiState [resAddr] _ h _ sts = last p'
|
TiState [resAddr] _ h _ sts = last p'
|
||||||
res = hLookupUnsafe resAddr h
|
res = hLookupUnsafe resAddr h
|
||||||
|
|
||||||
letrecExample :: Program
|
-- letrecExample :: Program
|
||||||
letrecExample = Program
|
-- letrecExample = Program
|
||||||
[ ScDef "pair" ["x","y","f"] $ "f" :$ "x" :$ "y"
|
-- [ ScDef "pair" ["x","y","f"] $ "f" :$ "x" :$ "y"
|
||||||
, ScDef "fst" ["p"] $ "p" :$ "K"
|
-- , ScDef "fst" ["p"] $ "p" :$ "K"
|
||||||
, ScDef "snd" ["p"] $ "p" :$ "K1"
|
-- , ScDef "snd" ["p"] $ "p" :$ "K1"
|
||||||
, ScDef "f" ["x","y"] $
|
-- , ScDef "f" ["x","y"] $
|
||||||
Let Rec
|
-- Let Rec
|
||||||
[ "a" := "pair" :$ "x" :$ "b"
|
-- [ "a" := "pair" :$ "x" :$ "b"
|
||||||
, "b" := "pair" :$ "y" :$ "a"
|
-- , "b" := "pair" :$ "y" :$ "a"
|
||||||
]
|
-- ]
|
||||||
("fst" :$ ("snd" :$ ("snd" :$ ("snd" :$ "a"))))
|
-- ("fst" :$ ("snd" :$ ("snd" :$ ("snd" :$ "a"))))
|
||||||
, ScDef "main" [] $ "f" :$ IntE 3 :$ IntE 4
|
-- , ScDef "main" [] $ "f" :$ IntE 3 :$ IntE 4
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
idExample :: Program
|
-- idExample :: Program
|
||||||
idExample = Program
|
-- idExample = Program
|
||||||
[ ScDef "main" [] $ "id" :$ IntE 3
|
-- [ ScDef "main" [] $ "id" :$ IntE 3
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
indExample1 :: Program
|
-- indExample1 :: Program
|
||||||
indExample1 = Program
|
-- indExample1 = Program
|
||||||
[ ScDef "main" [] $ "twice" :$ "twice" :$ "id" :$ IntE 3
|
-- [ ScDef "main" [] $ "twice" :$ "twice" :$ "id" :$ IntE 3
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
indExample2 :: Program
|
-- indExample2 :: Program
|
||||||
indExample2 = Program
|
-- indExample2 = Program
|
||||||
[ ScDef "main" [] $ "twice" :$ "twice" :$ "twice" :$ "id" :$ IntE 3
|
-- [ ScDef "main" [] $ "twice" :$ "twice" :$ "twice" :$ "id" :$ IntE 3
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
indExample3 :: Program
|
-- indExample3 :: Program
|
||||||
indExample3 = Program
|
-- indExample3 = Program
|
||||||
[ ScDef "main" [] $
|
-- [ ScDef "main" [] $
|
||||||
Let Rec
|
-- Let Rec
|
||||||
[ "x" := IntE 2
|
-- [ "x" := IntE 2
|
||||||
, "y" := "f" :$ "x" :$ "x"
|
-- , "y" := "f" :$ "x" :$ "x"
|
||||||
]
|
-- ]
|
||||||
("g" :$ "y" :$ "y")
|
-- ("g" :$ "y" :$ "y")
|
||||||
, ScDef "f" ["a","b"] $ "b"
|
-- , ScDef "f" ["a","b"] $ "b"
|
||||||
, ScDef "g" ["a","b"] $ "a"
|
-- , ScDef "g" ["a","b"] $ "a"
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
negExample1 :: Program
|
-- negExample1 :: Program
|
||||||
negExample1 = Program
|
-- negExample1 = Program
|
||||||
[ ScDef "main" [] $
|
-- [ ScDef "main" [] $
|
||||||
"negate#" :$ ("id" :$ IntE 3)
|
-- "negate#" :$ ("id" :$ IntE 3)
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
negExample2 :: Program
|
-- negExample2 :: Program
|
||||||
negExample2 = Program
|
-- negExample2 = Program
|
||||||
[ ScDef "main" [] $
|
-- [ ScDef "main" [] $
|
||||||
"negate#" :$ IntE 3
|
-- "negate#" :$ IntE 3
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
negExample3 :: Program
|
-- negExample3 :: Program
|
||||||
negExample3 = Program
|
-- negExample3 = Program
|
||||||
[ ScDef "main" [] $
|
-- [ ScDef "main" [] $
|
||||||
"twice" :$ "negate#" :$ IntE 3
|
-- "twice" :$ "negate#" :$ IntE 3
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
arithExample1 :: Program
|
-- arithExample1 :: Program
|
||||||
arithExample1 = Program
|
-- arithExample1 = Program
|
||||||
[ ScDef "main" [] $
|
-- [ ScDef "main" [] $
|
||||||
"+#" :$ (IntE 3) :$ ("negate#" :$ (IntE 2))
|
-- "+#" :$ (IntE 3) :$ ("negate#" :$ (IntE 2))
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
arithExample2 :: Program
|
-- arithExample2 :: Program
|
||||||
arithExample2 = Program
|
-- arithExample2 = Program
|
||||||
[ ScDef "main" [] $
|
-- [ ScDef "main" [] $
|
||||||
"negate#" :$ ("+#" :$ (IntE 2) :$ ("*#" :$ IntE 5 :$ IntE 3))
|
-- "negate#" :$ ("+#" :$ (IntE 2) :$ ("*#" :$ IntE 5 :$ IntE 3))
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
ifExample :: Program
|
-- ifExample :: Program
|
||||||
ifExample = Program
|
-- ifExample = Program
|
||||||
[ ScDef "main" [] $
|
-- [ ScDef "main" [] $
|
||||||
"if#" :$ "True" :$ IntE 2 :$ IntE 3
|
-- "if#" :$ "True" :$ IntE 2 :$ IntE 3
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
facExample :: Program
|
-- facExample :: Program
|
||||||
facExample = Program
|
-- facExample = Program
|
||||||
[ ScDef "fac" ["n"] $
|
-- [ ScDef "fac" ["n"] $
|
||||||
"if#" :$ ("==#" :$ "n" :$ IntE 0)
|
-- "if#" :$ ("==#" :$ "n" :$ IntE 0)
|
||||||
:$ (IntE 1)
|
-- :$ (IntE 1)
|
||||||
:$ ("*#" :$ "n" :$ ("fac" :$ ("-#" :$ "n" :$ IntE 1)))
|
-- :$ ("*#" :$ "n" :$ ("fac" :$ ("-#" :$ "n" :$ IntE 1)))
|
||||||
, ScDef "main" [] $ "fac" :$ IntE 3
|
-- , ScDef "main" [] $ "fac" :$ IntE 3
|
||||||
]
|
-- ]
|
||||||
|
|
||||||
----------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user