unproductive day i fear
This commit is contained in:
crumbtoo
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(..)
|
||||
, Name
|
||||
, ScDef(..)
|
||||
, Module(..)
|
||||
, Program(..)
|
||||
, corePrelude
|
||||
, bindersOf
|
||||
, rhssOf
|
||||
, isAtomic
|
||||
, insertModule
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -56,6 +58,9 @@ type Name = String
|
||||
data ScDef = ScDef Name [Name] Expr
|
||||
deriving (Show, Lift)
|
||||
|
||||
data Module = Module (Maybe (Name, [Name])) Program
|
||||
deriving (Show, Lift)
|
||||
|
||||
newtype Program = Program [ScDef]
|
||||
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
|
||||
prettyPrec (Var k) = withPrec maxBound $ IStr k
|
||||
prettyPrec (IntE n) = withPrec maxBound $ iShow n
|
||||
@@ -106,7 +120,7 @@ instance Pretty Binding where
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
instance Semigroup Program where
|
||||
(<>) = coerce $ (++) @ScDef
|
||||
(<>) = coerce $ (<>) @[ScDef]
|
||||
|
||||
instance Monoid Program where
|
||||
mempty = Program []
|
||||
@@ -125,15 +139,19 @@ isAtomic _ = False
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
corePrelude :: Program
|
||||
corePrelude = Program
|
||||
corePrelude :: Module
|
||||
corePrelude = Module (Just ("Prelude", [])) $ Program
|
||||
[ ScDef "id" ["x"] (Var "x")
|
||||
, ScDef "K" ["x", "y"] (Var "x")
|
||||
, ScDef "K1" ["x", "y"] (Var "y")
|
||||
, ScDef "S" ["f", "g", "x"] (Var "f" :$ Var "x" :$ (Var "g" :$ Var "x"))
|
||||
, ScDef "k" ["x", "y"] (Var "x")
|
||||
, ScDef "k1" ["x", "y"] (Var "y")
|
||||
, 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 "twice" ["f", "x"] (Var "f" :$ (Var "f" :$ Var "x"))
|
||||
, ScDef "False" [] $ Con 0 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"
|
||||
}
|
||||
|
||||
qCore :: String -> Q Exp
|
||||
qCore s = case lexCore s >>= parseCore of
|
||||
Success a -> lift a
|
||||
Error e _ _ -> error e
|
||||
qCore = undefined
|
||||
qCoreExpr = undefined
|
||||
|
||||
qCoreExpr :: String -> Q Exp
|
||||
qCoreExpr s = case lexCore s >>= parseCoreExpr of
|
||||
Success a -> lift a
|
||||
Error e _ _ -> error e
|
||||
-- qCore :: String -> Q Exp
|
||||
-- qCore s = case lexCore s >>= parseCore of
|
||||
-- Success a -> lift a
|
||||
-- Error e _ _ -> error e
|
||||
|
||||
-- qCoreExpr :: String -> Q Exp
|
||||
-- qCoreExpr s = case lexCore s >>= parseCoreExpr of
|
||||
-- Success a -> lift a
|
||||
-- Error e _ _ -> error e
|
||||
|
||||
|
||||
Reference in New Issue
Block a user