~jojo/Carth

98ab37e59ce10d5f25d2a91dffb651a2452e9860 — Johan Johansson 2 years ago a7f643b
Wrap ident in newtype, parse defs, parse program
7 files changed, 104 insertions(+), 29 deletions(-)

M app/Main.hs
M package.yaml
M src/Ast.hs
A src/Interp.hs
M src/Lib.hs
M src/Parse.hs
M test/ParseSpec.hs
M app/Main.hs => app/Main.hs +30 -1
@@ 1,6 1,35 @@
{-# LANGUAGE LambdaCase #-}

module Main where

import Control.Monad
import Data.Functor
import Lib

import System.Environment
import System.Exit

main :: IO ()
main = putStrLn "Hello, World!"
main = do
  args <- getArgs
  case args of
    file:[] -> interpretFile file
    _ -> usage

interpretFile :: FilePath -> IO ()
interpretFile file = parseFile file <&> interpret >>= \case
  Left err -> do
    putStrLn "Interpretation error"
    putStrLn err
    exitFailure
  Right () -> pure ()

parseFile :: String -> IO Program
parseFile file = readFile file <&> parse file >>= \case
  Left err -> do
    putStrLn "Syntax error"
    print err
    exitFailure
  Right pgm -> print pgm >> pure pgm

usage = putStrLn "Usage: carth SRC-FILE" >> exitFailure

M package.yaml => package.yaml +1 -0
@@ 23,6 23,7 @@ dependencies:
- parsec == 3.1.13.0
- either
- QuickCheck
- containers

library:
  source-dirs: src

M src/Ast.hs => src/Ast.hs +29 -17
@@ 1,12 1,15 @@
{-# LANGUAGE LambdaCase #-}

module Ast (Ident, Expr (..), pretty) where
module Ast (Id (..), Expr (..), Program (..), pretty) where

import Data.List (intercalate)
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Control.Monad
import Test.QuickCheck

type Ident = String
newtype Id = Id String
  deriving (Show, Eq, Ord)

data Expr
  = Unit


@@ 14,36 17,45 @@ data Expr
  | Double Double
  | Str String
  | Bool Bool
  | Var Ident
  | Var Id
  | App Expr Expr
  | If Expr Expr Expr
  | Lam Ident Expr
  | Let [(Ident, Expr)] Expr
  | Lam Id Expr
  | Let [(Id, Expr)] Expr
  deriving (Show, Eq)

type Defs = Map Id Expr

data Program = Program Expr Defs
  deriving (Show, Eq)

instance Arbitrary Program where
  arbitrary = applyArbitrary2 Program

instance Arbitrary Expr where
  arbitrary = frequency [ (5, pure Unit)
                        , (15, fmap Int arbitrary)
                        , (15, fmap Double arbitrary)
                        , (8, fmap (Str . getUnicodeString) arbitrary)
                        , (5, fmap Bool arbitrary)
                        , (30, fmap Var arbitraryIdent)
                        , (30, fmap Var arbitrary)
                        , (20, applyArbitrary2 App)
                        , (10, applyArbitrary3 If)
                        , (10, liftM2 Lam arbitraryIdent arbitrary)
                        , (10, applyArbitrary2 Lam)
                        , (10, arbitraryLet) ]
    where arbitraryIdent :: Gen Ident
          arbitraryIdent = choose (1, 15) >>= flip vectorOf c
          c = frequency [ (26, choose ('a', 'z'))
                        , (26, choose ('A', 'Z'))
                        , (4, elements ['_', '-', '+', '?']) ]
          arbitraryLet :: Gen Expr
    where arbitraryLet :: Gen Expr
          arbitraryLet = do
            n <- choose (0, 6)
            bindings <- vectorOf n (liftM2 (,) arbitraryIdent arbitrary)
            bindings <- vectorOf n (applyArbitrary2 (,))
            body <- arbitrary
            pure (Let bindings body)

instance Arbitrary Id where
  arbitrary = fmap Id (choose (1, 15) >>= flip vectorOf c)
    where c = frequency [ (26, choose ('a', 'z'))
                        , (26, choose ('A', 'Z'))
                        , (4, elements ['_', '-', '+', '?']) ]

-- variable def of name and val (expr)

-- def of either function/variable or data-type


@@ 62,7 74,7 @@ pretty' d = \case
  Double x -> show x
  Str s -> '"' : s ++ "\""
  Bool b -> if b then "true" else "false"
  Var v -> v
  Var (Id v) -> v
  App f x ->
    concat [ "(", pretty' (d + 1) f, "\n"
           , replicate (d + 1) ' ',  pretty' (d + 1) x, ")" ]


@@ 70,7 82,7 @@ pretty' d = \case
    concat [ "(if ", pretty' (d + 4) pred, "\n"
           , replicate (d + 4) ' ', pretty' (d + 4) cons, "\n"
           , replicate (d + 2) ' ', pretty' (d + 2) alt, ")" ]
  Lam param body ->
  Lam (Id param) body ->
    concat [ "(lambda [", param, "]", "\n"
           , replicate (d + 8) ' ', pretty' (d + 8) body, ")" ]
  Let binds body ->


@@ 79,6 91,6 @@ pretty' d = \case
                         (map (prettyBind (d + 6)) binds)
           , "]\n"
           , replicate (d + 2) ' ' ++ pretty' (d + 2) body, ")" ]
  where prettyBind d (var, val) =
  where prettyBind d (Id var, val) =
          concat [ "[", var, "\n"
                 , replicate (d + 1) ' ', pretty' (d + 1) val, "]" ]

A src/Interp.hs => src/Interp.hs +6 -0
@@ 0,0 1,6 @@
module Interp (interpret) where

import Ast

interpret :: Program -> Either String ()
interpret pgm = Left "not yet implemented"

M src/Lib.hs => src/Lib.hs +3 -3
@@ 1,5 1,5 @@
module Lib () where
module Lib (parse, Program, interpret) where

import Ast
import Parse


import Interp

M src/Parse.hs => src/Parse.hs +31 -5
@@ 1,10 1,12 @@
{-# LANGUAGE FlexibleContexts #-}

module Parse (parse, Expr (..)) where
module Parse (parse) where

import Control.Monad
import Data.Char (isMark, isPunctuation, isSymbol)
import Data.Functor
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import qualified Text.Parsec as Parsec
import Text.Parsec hiding (parse)



@@ 15,8 17,32 @@ type Parser = Parsec String ()
-- Use Parsec LanguageDef for easy handling of comments and reserved keywords
-- http://hackage.haskell.org/package/parsec-3.1.13.0/docs/Text-Parsec-Token.html

parse :: SourceName -> String -> Either ParseError Expr
parse = Parsec.parse expr
parse :: SourceName -> String -> Either ParseError Program
parse = Parsec.parse program

program :: Parser Program
program = do
  spaces
  defs <- fmap Map.fromList (sepEndBy def spaces)
  main <- maybe (fail "main function not defined") pure (Map.lookup (Id "main") defs)
  pure (Program main (Map.delete (Id "main") defs))

def :: Parser (Id, Expr)
def = parens (try (string "define" *> spaces1) *> (varDef <|> funDef))

varDef :: Parser (Id, Expr)
varDef = do
  name <- ident
  spaces1
  body <- expr
  pure (name, body)

funDef :: Parser (Id, Expr)
funDef = do
  (name, params) <- parens (liftM2 (,) ident (spaces1 *> sepEndBy1 ident spaces1))
  spaces1
  body <- expr
  pure (name, foldr Lam body params)

expr :: Parser Expr
expr = choice [unit, double, int, str, bool, var, pexpr]


@@ 92,8 118,8 @@ let' = do
  where
    binding = parens (liftM2 (,) ident (spaces1 *> expr))

ident :: Parser Ident
ident = identFirst <:> many identRest
ident :: Parser Id
ident = fmap Id (identFirst <:> many identRest)

identFirst = letter <|> symbol
identRest = identFirst <|> digit

M test/ParseSpec.hs => test/ParseSpec.hs +4 -3
@@ 10,6 10,7 @@ import Ast
import Parse

spec :: Spec
spec = describe "parse" $ do
  it "parses a program to an AST, and is the inverse of pretty"
     (withMaxSuccess 1e3 (\progAst -> parse "spec" (pretty progAst) == Right progAst))
spec = do
  describe "parse" $
    it "parses a program to an AST, and is the inverse of pretty" $
    withMaxSuccess 1e3 (\progAst -> parse "spec" (pretty progAst) == Right progAst)