gdritter repos earthling / 0d643c9
Basic working parser + bad interpreter Getty Ritter 6 years ago
10 changed file(s) with 436 addition(s) and 0 deletion(s). Collapse all Expand all
+2
-0
.gitignore less more
1 *~
2 dist-newstyle
+12
-0
LICENSE less more
1 Copyright (c) 2017, Getty Ritter
2 All rights reserved.
3
4 Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5
6 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7
8 2. 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.
9
10 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11
12 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 HOLDER 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.
+6
-0
earthling/Main.hs less more
1 module Main where
2
3 import qualified Earthling
4
5 main :: IO ()
6 main = Earthling.main
+38
-0
earthling.cabal less more
1 name: earthling
2 version: 0.1.0.0
3 -- synopsis:
4 -- description:
5 license: BSD3
6 license-file: LICENSE
7 author: Getty Ritter <gdritter@galois.com>
8 maintainer: Getty Ritter <gdritter@galois.com>
9 copyright: ©2017 Getty Ritter
10 -- category:
11 build-type: Simple
12 cabal-version: >= 1.14
13
14 library
15 exposed-modules: Earthling
16 , Earthling.Types
17 , Earthling.Lexer
18 , Earthling.Parser
19 , Earthling.Eval
20 hs-source-dirs: src
21 build-depends: base >=4.7 && <5
22 , text
23 , alex-tools
24 , containers
25 , array
26 , pretty-show
27 build-tools: alex, happy
28 default-language: Haskell2010
29 default-extensions: ScopedTypeVariables
30
31 executable earthling
32 hs-source-dirs: earthling
33 main-is: Main.hs
34 default-extensions: ScopedTypeVariables
35 ghc-options: -Wall
36 build-depends: base >=4.7 && <5
37 , earthling
38 default-language: Haskell2010
+6
-0
examples/arith.rth less more
1 -- this is a comment
2 -- definitions take the form `def name type body .`
3 @def t1 ('a -> 'a Int) 2 3 + 4 *.
4
5 -- the top-level is defined as main and should have the type [] -> []
6 @def main ([] -> []) t1 print.
+50
-0
src/Earthling/Eval.hs less more
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE OverloadedStrings #-}
3
4 module Earthling.Eval where
5
6 import qualified Data.Foldable as F
7 import Data.Sequence (Seq)
8 import qualified Data.Sequence as S
9 import Data.Text (Text)
10
11 import Earthling.Types
12
13 eval :: Seq (Decl 'Raw) -> IO ()
14 eval decls = case F.find (\ d -> declName d == "main") decls of
15 Nothing -> putStrLn "no main defined"
16 Just d -> do
17 _ <- runInstrs decls (S.viewl (declDefn d)) []
18 return ()
19
20 data Value
21 = IntValue Integer
22 | DoubleValue Double
23 deriving (Eq, Show)
24
25 runInstrs :: Seq (Decl 'Raw) -> S.ViewL (Item 'Raw) -> [Value] -> IO [Value]
26 runInstrs decls instrs stack = case instrs of
27 S.EmptyL -> return stack
28 i S.:< is -> do
29 stack' <- runInstr decls (itemTok i) stack
30 runInstrs decls (S.viewl is) stack'
31
32 builtins :: [(Text, [Value] -> IO [Value])]
33 builtins =
34 [ ("+", \ (IntValue x:IntValue y:rs) -> return (IntValue (x + y) : rs))
35 , ("*", \ (IntValue x:IntValue y:rs) -> return (IntValue (x * y) : rs))
36 , ("print", \ (val:rs) -> print val >> return rs)
37 ]
38
39 runInstr :: Seq (Decl 'Raw) -> Atom -> [Value] -> IO [Value]
40 runInstr _decls (AtomLiteral (IntLiteral i)) st =
41 return (IntValue i : st)
42 runInstr _decls (AtomLiteral (DoubleLiteral d)) st =
43 return (DoubleValue d : st)
44 runInstr decls (AtomIdent name) st
45 | Just cb <- lookup name builtins = cb st
46 | Just decl <- F.find (\ d -> declName d == name) decls =
47 runInstrs decls (S.viewl (declDefn decl)) st
48 | otherwise = do
49 putStrLn ("No definition named " ++ show name)
50 return []
+100
-0
src/Earthling/Lexer.x less more
1 {
2 {-# LANGUAGE TemplateHaskell #-}
3
4 module Earthling.Lexer where
5
6 import AlexTools
7 import qualified Data.Char as Char
8 import Data.Text (Text)
9 import qualified Data.Text as T
10 import qualified Data.Text.Read as T
11
12 }
13
14 $digit = [0-9]
15 $letter = [A-Za-z]
16 $upper = [A-Z]
17 $lower = [a-z]
18 $op = [\!\#\$\%\&\*\+\/\<\=\>\?\\\^\|\-\~]
19
20 @keyword = "@" [$lower] [$upper $lower _]+
21 @ident = [$lower $op] [$upper $lower $digit $op _]*
22 @constr = $upper [$upper $lower $digit $op _]*
23 @stackvar = "'" [$lower $op] [$upper $lower $digit $op _]*
24 @integer = [$digit]+
25 @double = [$digit]+ \. [$digit]+
26
27 :-
28
29 <0> {
30
31 $white+ ;
32
33 "--" .* ;
34
35 "{-" ( ([^\-] | \n)* ("-"[^\}])? )* "-}" ;
36
37 "(" { structure SLParen }
38 ")" { structure SRParen }
39 "[" { structure SLBrac }
40 "]" { structure SRBrac }
41 "{" { structure SLCurl }
42 "}" { structure SRCurl }
43 "." { structure SDot }
44 "->" { structure SArrow }
45
46 @keyword { doToken ret TokKeyword }
47 @ident { doToken ret TokIdent }
48 @constr { doToken ret TokConstr }
49 @stackvar { doToken ret TokStackVar }
50 @integer { doToken T.decimal TokInt }
51 @double { doToken T.double TokDouble }
52
53 }
54
55 {
56
57 data Tok
58 = TokKeyword Text
59 | TokIdent Text
60 | TokConstr Text
61 | TokInt Integer
62 | TokDouble Double
63 | TokStackVar Text
64 | TokStructure Structure
65 deriving (Eq, Show)
66
67 data Structure
68 = SLParen
69 | SRParen
70 | SLBrac
71 | SRBrac
72 | SLCurl
73 | SRCurl
74 | SDot
75 | SArrow
76 deriving (Eq, Show)
77
78 structure :: Structure -> Action () [Lexeme Tok]
79 structure s = lexeme (TokStructure s)
80
81 ret :: T.Reader Text
82 ret t = return (t, mempty)
83
84 doToken :: (T.Reader a) -> (a -> Tok) -> Action () [Lexeme Tok]
85 doToken reader f = do
86 t <- matchText
87 case reader t of
88 Right (res, _) -> lexeme (f res)
89 Left err -> error err
90
91 lexer :: Text -> [Lexeme Tok]
92 lexer str = $makeLexer simpleLexer input
93 where input = (initialInput str) { inputPos = start }
94 start = SourcePos 0 0 0
95
96 alexGetByte = makeAlexGetByte $ \ c ->
97 if Char.isAscii c
98 then toEnum (fromEnum c)
99 else 0x1
100 }
+142
-0
src/Earthling/Parser.y less more
1 {
2 {-# LANGUAGE ViewPatterns #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE OverloadedStrings #-}
5
6 module Earthling.Parser where
7
8 import Earthling.Types
9 import Earthling.Lexer
10
11 import AlexTools
12 import Data.Sequence (Seq)
13 import qualified Data.Sequence as S
14 import Data.Text (Text)
15 }
16
17 %tokentype { Lexeme Tok }
18
19 %token
20 IDENT { (matchIdent -> Just $$) }
21 CONSTR { (matchConstr -> Just $$) }
22 INT { (matchInt -> Just $$) }
23 DOUBLE { (matchDouble -> Just $$) }
24 STACKVAR { (matchStackVar -> Just $$) }
25
26 "@def" { Lexeme { lexemeToken = TokKeyword "@def" } }
27 "(" { Lexeme { lexemeToken = TokStructure SLParen } }
28 ")" { Lexeme { lexemeToken = TokStructure SRParen } }
29 "[" { Lexeme { lexemeToken = TokStructure SLBrac } }
30 "]" { Lexeme { lexemeToken = TokStructure SRBrac } }
31 "{" { Lexeme { lexemeToken = TokStructure SLCurl } }
32 "}" { Lexeme { lexemeToken = TokStructure SRCurl } }
33 "." { Lexeme { lexemeToken = TokStructure SDot } }
34 "->" { Lexeme { lexemeToken = TokStructure SArrow } }
35
36
37 %monad { Parse }
38 %error { parseError }
39
40 %name decls decls
41
42 %%
43
44 decls :: { Seq (Decl Raw) }
45 : list(decl) { $1 }
46
47 decl :: { Decl Raw }
48 : "@def" IDENT wordType instrSeq { Decl (fst $2) $3 $4 }
49
50 instrSeq :: { Seq (Item Raw) }
51 instrSeq
52 : "." { S.empty }
53 | atom instrSeq { $1 S.<| $2 }
54
55 wordType :: { WordType }
56 wordType
57 : "(" stackType "->" stackType ")"
58 { WordType $2 $4 }
59
60 stackType :: { StackType }
61 stackType : stackBase list(itemType) { StackType $1 $2 }
62
63 stackBase :: { StackBase }
64 stackBase
65 : "[" "]" { EmptyStack }
66 | STACKVAR { StackVar (fst $1) }
67
68 itemType :: { ItemType }
69 itemType
70 : IDENT { VarType (fst $1) }
71 | CONSTR { ConstrType (fst $1) }
72 | wordType { AtomType $1 }
73
74 atom :: { Item Raw }
75 atom
76 : IDENT { Item (AtomIdent (fst $1)) () }
77 | CONSTR { Item (AtomConstr (fst $1)) () }
78 | INT { Item (AtomLiteral (IntLiteral (fst $1))) () }
79 | DOUBLE { Item (AtomLiteral (DoubleLiteral (fst $1))) () }
80
81 -- utils
82
83 list(p) :: { Seq p }
84 : {- empty -} { S.empty }
85 | list1(p) { $1 }
86
87 list1(p) :: { Seq p }
88 : p { S.singleton $1 }
89 | list1(p) p { $1 S.|> $2 }
90
91 {
92
93 parseDecls :: Text -> Parse (Seq (Decl Raw))
94 parseDecls str = decls (lexer str)
95
96 type Parse = Either ParseError
97
98 data ParseError
99 = ParseError (Maybe SourcePos) String
100 deriving (Show)
101
102 parseError :: [Lexeme Tok] -> Parse a
103 parseError [] = Left (ParseError Nothing "")
104 parseError (t:_) =
105 Left (ParseError (Just (sourceFrom (lexemeRange t))) (show (lexemeToken t)))
106
107 matchIdent :: Lexeme Tok -> Maybe (Text, SourceRange)
108 matchIdent Lexeme
109 { lexemeToken = TokIdent t
110 , lexemeRange = r
111 } = Just (t, r)
112 matchIdent _ = Nothing
113
114 matchConstr :: Lexeme Tok -> Maybe (Text, SourceRange)
115 matchConstr Lexeme
116 { lexemeToken = TokConstr c
117 , lexemeRange = r
118 } = Just (c, r)
119 matchConstr _ = Nothing
120
121 matchInt :: Lexeme Tok -> Maybe (Integer, SourceRange)
122 matchInt Lexeme
123 { lexemeToken = TokInt i
124 , lexemeRange = r
125 } = Just (i, r)
126 matchInt _ = Nothing
127
128 matchDouble :: Lexeme Tok -> Maybe (Double, SourceRange)
129 matchDouble Lexeme
130 { lexemeToken = TokDouble d
131 , lexemeRange = r
132 } = Just (d, r)
133 matchDouble _ = Nothing
134
135 matchStackVar :: Lexeme Tok -> Maybe (Text, SourceRange)
136 matchStackVar Lexeme
137 { lexemeToken = TokStackVar d
138 , lexemeRange = r
139 } = Just (d, r)
140 matchStackVar _ = Nothing
141
142 }
+65
-0
src/Earthling/Types.hs less more
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE StandaloneDeriving #-}
4 {-# LANGUAGE TypeFamilies #-}
5 {-# LANGUAGE DataKinds #-}
6
7 module Earthling.Types where
8
9 import Data.Text (Text)
10 import Data.Sequence (Seq)
11
12 data Phase = Raw | Typed
13
14 type family TypeAnnot (p :: Phase) where
15 TypeAnnot 'Raw = ()
16 TypeAnnot 'Typed = WordType
17
18 data WordType = WordType
19 { stackIn :: StackType
20 , stackOut :: StackType
21 } deriving (Eq, Show)
22
23 data StackType = StackType
24 { baseStackType :: StackBase
25 , topStackType :: Seq ItemType
26 } deriving (Eq, Show)
27
28 data StackBase
29 = EmptyStack
30 | StackVar Text
31 deriving (Eq, Show)
32
33 data ItemType
34 = VarType Text
35 | ConstrType Text
36 | AtomType WordType
37 deriving (Eq, Show)
38
39 data Decl p = Decl
40 { declName :: Text
41 , declType :: WordType
42 , declDefn :: Seq (Item p)
43 }
44
45 deriving instance Eq (TypeAnnot p) => Eq (Decl p)
46 deriving instance Show (TypeAnnot p) => Show (Decl p)
47
48 data Item p = Item
49 { itemTok :: Atom
50 , itemType :: TypeAnnot p
51 }
52
53 deriving instance Eq (TypeAnnot p) => Eq (Item p)
54 deriving instance Show (TypeAnnot p) => Show (Item p)
55
56 data Atom
57 = AtomIdent Text
58 | AtomConstr Text
59 | AtomLiteral Literal
60 deriving (Eq, Show)
61
62 data Literal
63 = IntLiteral Integer
64 | DoubleLiteral Double
65 deriving (Eq, Show)
+15
-0
src/Earthling.hs less more
1 module Earthling where
2
3 import qualified Data.Text.IO as T
4 import qualified Text.Show.Pretty as Pretty
5
6 import qualified Earthling.Parser as Earthling
7 import qualified Earthling.Eval as Earthling
8
9 main :: IO ()
10 main = do
11 cs <- T.getContents
12 let decls = Earthling.parseDecls cs
13 case decls of
14 Left err -> print err
15 Right ds -> Earthling.eval ds