~jojo/Carth: src/Ast.hs - sourcehut git


                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
{-# LANGUAGE LambdaCase #-}

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

import Data.List (intercalate)
import Control.Monad
import Test.QuickCheck

type Ident = String

data Expr
  = Nil
  | Int Int
  | Double Double
  | Str String
  | Bool Bool
  | Var Ident
  | App Expr Expr
  | If Expr Expr Expr
  | Lam Ident Expr
  | Let [(Ident, Expr)] Expr
  deriving (Show, Eq)

instance Arbitrary Expr where
  arbitrary = frequency [ (5, pure Nil)
                        , (15, fmap Int arbitrary)
                        , (15, fmap Double arbitrary)
                        , (8, fmap (Str . getUnicodeString) arbitrary)
                        , (5, fmap Bool arbitrary)
                        , (30, fmap Var arbitraryIdent)
                        , (20, applyArbitrary2 App)
                        , (10, applyArbitrary3 If)
                        , (10, liftM2 Lam arbitraryIdent arbitrary)
                        , (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
          arbitraryLet = do
            n <- choose (0, 6)
            bindings <- vectorOf n (liftM2 (,) arbitraryIdent arbitrary)
            body <- arbitrary
            pure (Let bindings body)

-- variable def of name and val (expr)

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

-- program of defs, main

-- Pretty print an AST
pretty :: Expr -> String
pretty = pretty' 0

-- Pretty print starting at indentation depth `d`
pretty' :: Int -> Expr -> String
pretty' d = \case
  Nil -> "nil"
  Int n -> show n
  Double x -> show x
  Str s -> '"' : s ++ "\""
  Bool b -> if b then "true" else "false"
  Var v -> v
  App f x ->
    concat [ "(", pretty' (d + 1) f, "\n"
           , replicate (d + 1) ' ',  pretty' (d + 1) x, ")" ]
  If pred cons alt ->
    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 ->
    concat [ "(lambda [", param, "]", "\n"
           , replicate (d + 8) ' ', pretty' (d + 8) body, ")" ]
  Let binds body ->
    concat [ "(let ["
           , intercalate ("\n" ++ replicate (d + 6) ' ')
                         (map (prettyBind (d + 6)) binds)
           , "]\n"
           , replicate (d + 2) ' ' ++ pretty' (d + 2) body, ")" ]
  where prettyBind d (var, val) =
          concat [ "[", var, "\n"
                 , replicate (d + 1) ' ', pretty' (d + 1) val, "]" ]