├── src ├── Language.hs └── Language │ ├── Entry.hs │ ├── Repl.hs │ ├── Pretty.hs │ ├── Syntax.hs │ └── Parser.hs ├── .gitignore ├── stack.yaml ├── test ├── Spec.hs └── Language │ ├── PrettySpec.hs │ └── ParserSpec.hs ├── Setup.hs ├── app └── Main.hs ├── readme.md ├── .editorconfig ├── .travis.yml ├── package.yaml └── license /src/Language.hs: -------------------------------------------------------------------------------- 1 | module Language () where 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.cabal 2 | .vscode 3 | .stack-work 4 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.0 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Language.Entry 4 | -------------------------------------------------------------------------------- /src/Language/Entry.hs: -------------------------------------------------------------------------------- 1 | module Language.Entry ( 2 | main, 3 | ) where 4 | 5 | import Language.Repl 6 | 7 | main :: IO () 8 | main = repl 9 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # tlc 2 | 3 | [![Build Status][build-badge]][build-status] 4 | 5 | [build-badge]: https://img.shields.io/travis/airt/tlc.svg 6 | [build-status]: https://travis-ci.org/airt/tlc 7 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | indent_style = space 5 | indent_size = 2 6 | end_of_line = lf 7 | charset = utf-8 8 | trim_trailing_whitespace = true 9 | insert_final_newline = true 10 | 11 | [Makefile] 12 | indent_style = tab 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # https://docs.haskellstack.org/en/stable/travis_ci/ 2 | 3 | language: generic 4 | 5 | cache: 6 | directories: 7 | - $HOME/.stack 8 | 9 | addons: 10 | apt: 11 | packages: 12 | - libgmp-dev 13 | 14 | before_install: 15 | - mkdir -p ~/.local/bin 16 | - export PATH=$HOME/.local/bin:$PATH 17 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 18 | 19 | install: 20 | - stack --no-terminal --install-ghc test --only-dependencies 21 | 22 | script: 23 | - stack --no-terminal test --haddock --no-haddock-deps 24 | -------------------------------------------------------------------------------- /src/Language/Repl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Language.Repl ( 4 | repl, 5 | ) where 6 | 7 | import Control.Category 8 | import Control.Monad.IO.Class 9 | import Data.Text 10 | import System.Console.Haskeline 11 | import Language.Parser 12 | import Language.Pretty 13 | 14 | process :: Text -> IO () 15 | process = parses [] >>> \case 16 | Left e -> print e 17 | Right x -> do 18 | pprint x 19 | print x 20 | 21 | loop :: InputT IO () 22 | loop = getInputLine "> " >>= \case 23 | Nothing -> return () 24 | Just input -> liftIO (process $ pack input) >> loop 25 | 26 | repl :: IO () 27 | repl = runInputT defaultSettings loop 28 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: tlc 2 | version: 0.0.1 3 | synopsis: .. 4 | maintainer: airt 5 | license: MIT 6 | github: airt/tlc 7 | 8 | dependencies: 9 | - base 10 | - containers 11 | - haskeline 12 | - mtl 13 | - optparse-applicative 14 | - parsec 15 | - pretty 16 | - text 17 | 18 | library: 19 | source-dirs: src 20 | exposed-modules: 21 | - Language 22 | - Language.Entry 23 | - Language.Parser 24 | - Language.Pretty 25 | - Language.Syntax 26 | 27 | executable: 28 | main: Main.hs 29 | source-dirs: app 30 | dependencies: 31 | - tlc 32 | 33 | tests: 34 | spec: 35 | main: Spec.hs 36 | source-dirs: test 37 | dependencies: 38 | - tlc 39 | - hspec 40 | -------------------------------------------------------------------------------- /src/Language/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | module Language.Pretty ( 6 | pprint, 7 | pretty, 8 | ) where 9 | 10 | import Data.Char 11 | import Data.Text 12 | import Data.Text.IO 13 | import Numeric 14 | import Text.PrettyPrint 15 | import Language.Syntax 16 | 17 | pprint :: Expression -> IO () 18 | pprint = Data.Text.IO.putStrLn . pretty 19 | 20 | pretty :: Expression -> Text 21 | pretty = pack . render . codify 22 | 23 | codify :: Expression -> Doc 24 | codify = \case 25 | Identifier x -> text $ unpack x 26 | Integer n -> integer n 27 | Floating n -> double n 28 | Character c -> "#\\" <> escape c 29 | Boolean b -> if b then "#t" else "#f" 30 | String s -> text $ show s 31 | Quote x -> char '\'' <> codify x 32 | List xs -> parens . hsep $ codify <$> xs 33 | Vector xs -> char '#' <> codify (List xs) 34 | 35 | escape :: Char -> Doc 36 | escape = \case 37 | (findNameOfCharacter -> Just n) -> text $ unpack n 38 | c | c > '\x7F' -> char 'x' <> text (showHex (ord c) []) 39 | c -> char c 40 | -------------------------------------------------------------------------------- /license: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2017 airt 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/Language/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | 4 | module Language.Syntax ( 5 | Expression(.., Quote), 6 | findCharacterByName, 7 | findNameOfCharacter, 8 | ) where 9 | 10 | import Data.Map 11 | import Data.String 12 | import Data.Text 13 | import Data.Tuple 14 | import Data.Typeable 15 | 16 | data Expression = 17 | Identifier Text | 18 | Integer Integer | 19 | Floating Double | 20 | Character Char | 21 | Boolean Bool | 22 | String Text | 23 | List [Expression] | 24 | Vector [Expression] 25 | deriving (Eq, Show, Typeable) 26 | 27 | pattern Quote :: Expression -> Expression 28 | pattern Quote x = List [Identifier "quote", x] 29 | 30 | instance IsString Expression where 31 | fromString = Identifier . pack 32 | 33 | findCharacterByName :: Text -> Maybe Char 34 | findCharacterByName = (m !?) 35 | where 36 | m = Data.Map.fromList namedCharacters 37 | 38 | findNameOfCharacter :: Char -> Maybe Text 39 | findNameOfCharacter = (m !?) 40 | where 41 | m = Data.Map.fromList $ swap <$> namedCharacters 42 | 43 | namedCharacters :: [(Text, Char)] 44 | namedCharacters = 45 | [ 46 | ("alarm", '\a'), 47 | ("backspace", '\b'), 48 | ("delete", '\DEL'), 49 | ("escape", '\ESC'), 50 | ("newline", '\n'), 51 | ("null", '\NUL'), 52 | ("return", '\r'), 53 | ("space", ' '), 54 | ("tab", '\t') 55 | ] 56 | -------------------------------------------------------------------------------- /test/Language/PrettySpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Language.PrettySpec where 4 | 5 | import Test.Hspec 6 | import Language.Pretty 7 | import Language.Syntax 8 | 9 | spec :: Spec 10 | spec = describe "Pretty" $ do 11 | 12 | it "Identifier" $ do 13 | pretty (Identifier "λ") `shouldBe` "λ" 14 | pretty (Identifier "-") `shouldBe` "-" 15 | pretty (Identifier "equal?") `shouldBe` "equal?" 16 | 17 | it "Integer" $ do 18 | pretty (Integer 10) `shouldBe` "10" 19 | pretty (Integer (-10)) `shouldBe` "-10" 20 | 21 | it "Floating" $ do 22 | pretty (Floating 10.01) `shouldBe` "10.01" 23 | pretty (Floating (-10.01)) `shouldBe` "-10.01" 24 | 25 | it "Character" $ do 26 | pretty (Character 'x') `shouldBe` "#\\x" 27 | pretty (Character '\'') `shouldBe` "#\\'" 28 | pretty (Character '\\') `shouldBe` "#\\\\" 29 | pretty (Character ' ') `shouldBe` "#\\space" 30 | pretty (Character 'λ') `shouldBe` "#\\x3bb" 31 | 32 | it "Boolean" $ do 33 | pretty (Boolean True) `shouldBe` "#t" 34 | pretty (Boolean False) `shouldBe` "#f" 35 | 36 | it "String" $ do 37 | pretty (String "") `shouldBe` "\"\"" 38 | pretty (String "xx") `shouldBe` "\"xx\"" 39 | pretty (String "x\nx") `shouldBe` "\"x\\nx\"" 40 | pretty (String "x\"x") `shouldBe` "\"x\\\"x\"" 41 | pretty (String "x\\x") `shouldBe` "\"x\\\\x\"" 42 | 43 | it "List" $ do 44 | pretty (List []) `shouldBe` "()" 45 | pretty (List [Identifier "x"]) `shouldBe` "(x)" 46 | pretty (List [Identifier "x", Identifier "y"]) `shouldBe` "(x y)" 47 | pretty (List [Identifier "x", List [Identifier "y"]]) `shouldBe` "(x (y))" 48 | "(x 1 0.1 #\\c #t \" \" () #() '())" `shouldBe` 49 | pretty (List [ 50 | Identifier "x", 51 | Integer 1, 52 | Floating 0.1, 53 | Character 'c', 54 | Boolean True, 55 | String " ", 56 | List [], 57 | Vector [], 58 | List [Identifier "quote", List []] 59 | ]) 60 | 61 | it "Vector" $ do 62 | pretty (Vector []) `shouldBe` "#()" 63 | pretty (Vector [Identifier "x"]) `shouldBe` "#(x)" 64 | pretty (Vector [Identifier "x", Identifier "y"]) `shouldBe` "#(x y)" 65 | pretty (Vector [Identifier "x", Vector [Identifier "y"]]) `shouldBe` "#(x #(y))" 66 | 67 | it "Quotation" $ do 68 | pretty (List [Identifier "quote", Identifier "x"]) `shouldBe` "'x" 69 | pretty (List [Identifier "quote", List [Identifier "quote", Identifier "x"]]) `shouldBe` "''x" 70 | pretty (List [Identifier "quote", List [List [Identifier "quote", List []]]]) `shouldBe` "'('())" 71 | -------------------------------------------------------------------------------- /test/Language/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Language.ParserSpec where 5 | 6 | import Control.Category 7 | import Data.Text 8 | import Test.Hspec 9 | import Language.Parser 10 | import Language.Syntax 11 | 12 | spec :: Spec 13 | spec = describe "Parser" $ do 14 | 15 | it "Identifier" $ do 16 | p "λ" `shouldBe` Identifier "λ" 17 | p "-" `shouldBe` Identifier "-" 18 | p "equal?" `shouldBe` Identifier "equal?" 19 | 20 | it "Integer" $ do 21 | p "10" `shouldBe` Integer 10 22 | p "-10" `shouldBe` Integer (-10) 23 | 24 | it "Floating" $ do 25 | p "10.01" `shouldBe` Floating 10.01 26 | p "-10.01" `shouldBe` Floating (-10.01) 27 | 28 | it "Character" $ do 29 | p "#\\x" `shouldBe` Character 'x' 30 | p "#\\ " `shouldBe` Character ' ' 31 | p "#\\\\" `shouldBe` Character '\\' 32 | p "#\\space" `shouldBe` Character ' ' 33 | p "#\\x03BB" `shouldBe` Character 'λ' 34 | 35 | it "Boolean" $ do 36 | p "#t" `shouldBe` Boolean True 37 | p "#f" `shouldBe` Boolean False 38 | 39 | it "String" $ do 40 | p "\"\"" `shouldBe` String "" 41 | p "\"xx\"" `shouldBe` String "xx" 42 | p "\"x\\nx\"" `shouldBe` String "x\nx" 43 | p "\"x\\\"x\"" `shouldBe` String "x\"x" 44 | p "\"x\\\\x\"" `shouldBe` String "x\\x" 45 | 46 | it "List" $ do 47 | p "()" `shouldBe` List [] 48 | p "(x)" `shouldBe` List [Identifier "x"] 49 | p "( x )" `shouldBe` List [Identifier "x"] 50 | p "(x y)" `shouldBe` List [Identifier "x", Identifier "y"] 51 | p "(x (y))" `shouldBe` List [Identifier "x", List [Identifier "y"]] 52 | p "(x 1 0.1 #\\c #t \" \" () #() '())" `shouldBe` 53 | List [ 54 | Identifier "x", 55 | Integer 1, 56 | Floating 0.1, 57 | Character 'c', 58 | Boolean True, 59 | String " ", 60 | List [], 61 | Vector [], 62 | List [Identifier "quote", List []] 63 | ] 64 | 65 | it "Vector" $ do 66 | p "#()" `shouldBe` Vector [] 67 | p "#(x)" `shouldBe` Vector [Identifier "x"] 68 | p "#( x )" `shouldBe` Vector [Identifier "x"] 69 | p "#(x y)" `shouldBe` Vector [Identifier "x", Identifier "y"] 70 | p "#(x #(y))" `shouldBe` Vector [Identifier "x", Vector [Identifier "y"]] 71 | 72 | it "Quotation" $ do 73 | p "'x" `shouldBe` List [Identifier "quote", Identifier "x"] 74 | p "''x" `shouldBe` List [Identifier "quote", List [Identifier "quote", Identifier "x"]] 75 | p "'()" `shouldBe` List [Identifier "quote", List []] 76 | p "'('())" `shouldBe` List [Identifier "quote", List [List [Identifier "quote", List []]]] 77 | p "' ( ' () )" `shouldBe` List [Identifier "quote", List [List [Identifier "quote", List []]]] 78 | 79 | it "Comment" $ do 80 | p "x;c\n" `shouldBe` Identifier "x" 81 | p "x ; c \n" `shouldBe` Identifier "x" 82 | p "( x ; c \n y )" `shouldBe` List [Identifier "x", Identifier "y"] 83 | p "( x #| c |# y )" `shouldBe` List [Identifier "x", Identifier "y"] 84 | 85 | p :: Text -> Expression 86 | p = parses [] >>> \case 87 | Left e -> errorWithoutStackTrace $ show e 88 | Right x -> x 89 | -------------------------------------------------------------------------------- /src/Language/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Language.Parser ( 4 | parse, 5 | parses, 6 | ) where 7 | 8 | import Data.Char 9 | import Data.Functor.Identity 10 | import Data.Maybe 11 | import Data.Text 12 | import Numeric 13 | import Text.Parsec hiding (parse, string) 14 | import Text.Parsec.Text 15 | import Language.Syntax 16 | import qualified Text.Parsec.Token as Token 17 | 18 | parse :: SourceName -> Text -> Either ParseError [Expression] 19 | parse = runParser (completes expressions) () 20 | 21 | parses :: SourceName -> Text -> Either ParseError Expression 22 | parses = runParser (completes expression) () 23 | 24 | expression :: Parser Expression 25 | expression = 26 | vector <|> 27 | list <|> 28 | string <|> 29 | boolean <|> 30 | character <|> 31 | floating <|> 32 | integer <|> 33 | identifier <|> 34 | quotation 35 | "expression" 36 | 37 | expressions :: Parser [Expression] 38 | expressions = many $ lexeme expression 39 | 40 | quotation :: Parser Expression 41 | quotation = Quote <$> (lexeme (char '\'') *> expression) 42 | 43 | identifier :: Parser Expression 44 | identifier = Identifier . pack <$> Token.identifier lexer 45 | 46 | integer :: Parser Expression 47 | integer = Integer <$> try (sign <*> Token.natural lexer) 48 | 49 | floating :: Parser Expression 50 | floating = Floating <$> try (sign <*> Token.float lexer) 51 | 52 | character :: Parser Expression 53 | character = Character <$> (try prefix *> contents) 54 | where 55 | prefix = char '#' *> char '\\' 56 | contents = try single <|> scalar <|> named 57 | single = anyChar <* notFollowedBy alphaNum 58 | scalar = maybe (fail "invalid hex scalar") return . rx =<< char 'x' *> many hexDigit 59 | named = maybe (fail "unsupported character name") return . rn =<< Token.identifier lexer 60 | rx = ((chr . fst) <$>) . listToMaybe . readHex 61 | rn = findCharacterByName . pack 62 | 63 | boolean :: Parser Expression 64 | boolean = Boolean . (== 't') <$> try (char '#' *> oneOf "tf") 65 | 66 | string :: Parser Expression 67 | string = String . pack <$> Token.stringLiteral lexer 68 | 69 | list :: Parser Expression 70 | list = List <$> parens expressions 71 | 72 | vector :: Parser Expression 73 | vector = Vector <$> try (char '#' *> parens expressions) 74 | 75 | sign :: Num n => Parser (n -> n) 76 | sign = (negate <$ char '-') <|> (id <$ char '+') <|> return id 77 | 78 | completes :: Parser a -> Parser a 79 | completes = between (Token.whiteSpace lexer) eof . lexeme 80 | 81 | parens :: Parser a -> Parser a 82 | parens p = Token.parens lexer p <|> Token.brackets lexer p 83 | 84 | lexeme :: Parser a -> Parser a 85 | lexeme = Token.lexeme lexer 86 | 87 | symbol :: Parser Char 88 | symbol = oneOf "!$%&*+-./:<=>?@^_~" 89 | 90 | lexer :: Token.GenTokenParser Text () Identity 91 | lexer = Token.makeTokenParser Token.LanguageDef { 92 | Token.commentStart = "#|", 93 | Token.commentEnd = "|#", 94 | Token.commentLine = ";", 95 | Token.nestedComments = True, 96 | Token.identStart = letter <|> symbol, 97 | Token.identLetter = letter <|> digit <|> symbol, 98 | Token.opStart = unexpected "operator", 99 | Token.opLetter = unexpected "operator", 100 | Token.reservedNames = [], 101 | Token.reservedOpNames = [], 102 | Token.caseSensitive = True 103 | } 104 | --------------------------------------------------------------------------------