├── .gitignore
├── README.md
├── default.nix
├── meta-lambda.cabal
├── meta-lambda.nix
├── shell.nix
├── src
    └── Syntax.hs
└── test
    └── Main.hs


/.gitignore:
--------------------------------------------------------------------------------
1 | 
2 | dist/
3 | dist-newstyle/
4 | result
5 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | Experiments with a lambda calculus that has "quote" and "unquote"
2 | 


--------------------------------------------------------------------------------
/default.nix:
--------------------------------------------------------------------------------
 1 | { nixpkgs ? import <nixpkgs> {}, compiler ? "ghc822" }:
 2 | 
 3 | let
 4 | 
 5 |   inherit (nixpkgs) pkgs;
 6 | 
 7 |   f = import ./meta-lambda.nix;
 8 | 
 9 |   haskellPackages = if compiler == "default"
10 |                        then pkgs.haskellPackages
11 |                        else pkgs.haskell.packages.${compiler};
12 | 
13 |   drv = haskellPackages.callPackage f {};
14 | 
15 | in
16 | 
17 |   drv
18 | 


--------------------------------------------------------------------------------
/meta-lambda.cabal:
--------------------------------------------------------------------------------
 1 | -- Initial meta-lambda.cabal generated by cabal init.  For further documentation,
 2 | -- see http://haskell.org/cabal/users-guide/
 3 | 
 4 | name:                meta-lambda
 5 | version:             0.1.0.0
 6 | -- synopsis:
 7 | -- description:
 8 | license:             BSD3
 9 | --                   Must be spelled with a 'C' for nix
10 | -- license-file:        LICENCE
11 | author:              Isaac Elliott
12 | maintainer:          isaace71295@gmail.com
13 | -- copyright:
14 | -- category:
15 | build-type:          Simple
16 | extra-source-files:  ChangeLog.md
17 | cabal-version:       >=1.10
18 | 
19 | library
20 |   exposed-modules:     Syntax
21 |   -- other-modules:
22 |   -- other-extensions:
23 |   hs-source-dirs:      src
24 |   build-depends:       base >=4.9 && <5
25 |                      , megaparsec >=6.0 && <6.1
26 |                      , lens >=4.15 && <4.17
27 |   default-language:    Haskell2010
28 |   ghc-options:         -Wincomplete-patterns
29 | 
30 | test-suite meta-lambda-tests
31 |   type:                exitcode-stdio-1.0
32 |   main-is:             Main.hs
33 |   hs-source-dirs:      test
34 |   build-depends:       base >=4.9 && <5
35 |                      , meta-lambda
36 |                      , lens >=4.15 && <4.17
37 |                      , hedgehog >=0.5 && <0.6
38 |   default-language:    Haskell2010
39 |   ghc-options:         -Wincomplete-patterns
40 | 


--------------------------------------------------------------------------------
/meta-lambda.nix:
--------------------------------------------------------------------------------
 1 | { mkDerivation, base, hedgehog, lens, megaparsec, stdenv }:
 2 | mkDerivation {
 3 |   pname = "meta-lambda";
 4 |   version = "0.1.0.0";
 5 |   src = ./.;
 6 |   libraryHaskellDepends = [ base lens megaparsec ];
 7 |   testHaskellDepends = [ base hedgehog lens ];
 8 |   license = stdenv.lib.licenses.bsd3;
 9 | }
10 | 


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
 1 | { nixpkgs ? import <nixpkgs> {}, compiler ? "ghc822" }:
 2 | 
 3 | let
 4 | 
 5 |   drv = import ./default.nix { inherit nixpkgs compiler; };
 6 | 
 7 | in
 8 | 
 9 |   drv.env
10 | 


--------------------------------------------------------------------------------
/src/Syntax.hs:
--------------------------------------------------------------------------------
  1 | {-# language TypeFamilies, OverloadedStrings, FlexibleContexts #-}
  2 | {-# language LambdaCase #-}
  3 | {-# language BangPatterns #-}
  4 | {-# language DeriveGeneric #-}
  5 | module Syntax where
  6 | 
  7 | import Control.Applicative ((<|>), liftA2, many, some)
  8 | import Control.Lens.Getter ((^.))
  9 | import Control.Lens.Lens (Lens', lens)
 10 | import Control.Lens.Plated (Plated(..), gplate)
 11 | import Control.Lens.Setter (over)
 12 | import Data.Functor ((<$), ($>))
 13 | import Data.Semigroup ((<>))
 14 | import Data.String (IsString)
 15 | import GHC.Generics (Generic)
 16 | import Text.Megaparsec
 17 |   (MonadParsec, Token, Tokens, ParseError, Parsec, SourcePos(..), unPos,
 18 |    between, parse, sepBy, getPosition)
 19 | import Text.Megaparsec.Char
 20 |   (char, notChar, upperChar, lowerChar, letterChar, spaceChar, newline,
 21 |    digitChar, string)
 22 | import Text.Megaparsec.Expr (makeExprParser, Operator(InfixL))
 23 | 
 24 | data SrcInfo
 25 |   = SrcInfo
 26 |   { _srcName :: String
 27 |   , _srcLine :: Int
 28 |   , _srcColumn :: Int
 29 |   } deriving (Eq, Show)
 30 | 
 31 | data Expr a
 32 |   = Var String (Maybe a)
 33 |   | Bound Int (Maybe a)
 34 |   | Lam (Expr a) (Maybe a)
 35 |   | Ctor String [Expr a] (Maybe a)
 36 |   | Unquote (Expr a) (Maybe a)
 37 |   | Quote (Expr a) (Maybe a)
 38 |   | App (Expr a) (Expr a) (Maybe a)
 39 |   | String String (Maybe a)
 40 |   | Int Int (Maybe a)
 41 |   deriving (Eq, Show, Generic)
 42 | 
 43 | instance Plated (Expr a) where; plate = gplate
 44 | 
 45 | abstract :: String -> Expr a -> Maybe a -> Expr a
 46 | abstract v e = Lam (fun 0 e)
 47 |   where
 48 |     fun !n t =
 49 |       case t of
 50 |         Var v' ann
 51 |           | v == v' -> Bound n ann
 52 |           | otherwise -> t
 53 |         Lam{} -> over plate (fun $ n+1) t
 54 |         _ -> over plate (fun n) t
 55 | 
 56 | exprAnn :: Lens' (Expr a) (Maybe a)
 57 | exprAnn =
 58 |   lens
 59 |     (\case
 60 |         Var _ a -> a
 61 |         Bound _ a -> a
 62 |         Lam _ a -> a
 63 |         Ctor _ _ a -> a
 64 |         Unquote _ a -> a
 65 |         Quote _ a -> a
 66 |         App _ _ a -> a
 67 |         String _ a -> a
 68 |         Int _ a -> a)
 69 |     (\e ann ->
 70 |        case e of
 71 |          Var a _ -> Var a ann
 72 |          Bound a _ -> Bound a ann
 73 |          Lam c _ -> Lam c ann
 74 |          Ctor a b _ -> Ctor a b ann
 75 |          Unquote a _ -> Unquote a ann
 76 |          Quote a _ -> Quote a ann
 77 |          App a b _ -> App a b ann
 78 |          String a _ -> String a ann
 79 |          Int a _ -> Int a ann)
 80 | 
 81 | data Decl a
 82 |   = Binding String (Expr a) (Maybe a)
 83 |   deriving (Eq, Show)
 84 | 
 85 | newtype Module a = Module [Decl a]
 86 |   deriving (Eq, Show)
 87 | 
 88 | 
 89 | expr :: (MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) => m (Expr SrcInfo)
 90 | expr = lam <|> app
 91 |   where
 92 |     lam = do
 93 |       SourcePos f line col <- getPosition
 94 |       (\name e ->
 95 |          abstract
 96 |            name
 97 |            e
 98 |            (Just $ SrcInfo f (unPos line) (unPos col))) <$
 99 |         char '\\' <*>
100 |         liftA2 (:) lowerChar (many letterChar) <*
101 |         string "->" <*>
102 |         expr
103 | 
104 |     app =
105 |       makeExprParser
106 |         atom
107 |         [[InfixL (some spaceChar $> (\a b -> App a b (a ^. exprAnn)))]]
108 | 
109 |     atom = do
110 |       SourcePos name line col <- getPosition
111 |       (Var <$> some letterChar <|>
112 |        Quote <$ char '\'' <*> atom <|>
113 |        Unquote <$ char '$' <*> atom <|>
114 |        String <$> between (char '"') (char '"') (many (notChar '"')) <|>
115 |        Int . read <$> some digitChar) <*>
116 |         pure (Just $ SrcInfo name (unPos line) (unPos col)) <|>
117 |         between (char '(') (char ')') expr
118 | 
119 | decl :: (MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) => m (Decl SrcInfo)
120 | decl = do
121 |   SourcePos name line col <- getPosition
122 |   Binding <$>
123 |     some letterChar <* char '=' <*>
124 |     expr <*>
125 |     pure (Just $ SrcInfo name (unPos line) (unPos col))
126 | 
127 | module_ :: (MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) => m (Module SrcInfo)
128 | module_ = Module <$> sepBy decl newline
129 | 
130 | parseFile :: Parsec e String a -> FilePath -> IO (Either (ParseError Char e) a)
131 | parseFile p fp = parse p fp <$> readFile fp
132 | 
133 | parseInteractive :: Parsec e s a -> s -> Either (ParseError (Token s) e) a
134 | parseInteractive p str = parse p "interactive" str
135 | 
136 | unquoteList :: (Expr SrcInfo -> a) -> Expr SrcInfo -> [a]
137 | unquoteList f (Ctor "Nil" [] _) = []
138 | unquoteList f (Ctor "Cons" [x, xs] _) = f x : unquoteList f xs
139 | unquoteList _ a = error $ "can't unquote " ++ show a
140 | 
141 | unquote :: Expr SrcInfo -> Expr SrcInfo
142 | unquote = go Nothing
143 |   where
144 |     go (Just n) (Bound n' a) | n' <= n = Bound n' a
145 |     go inLambda (Ctor "Var" [String s _, _] ann) = Var s ann
146 |     go inLambda (Ctor "Lam" [Lam e _, _] ann) =
147 |       Lam (go ((+1) <$> inLambda <|> Just 0) e) ann
148 |     go inLambda (Ctor "App" [f, x, _] ann) = App (go inLambda f) (go inLambda x) ann
149 |     go inLambda (Ctor "String" [String s _, _] ann) = String s ann
150 |     go inLambda (Ctor "Int" [Int i _, _] ann) = Int i ann
151 |     go inLambda (Ctor "Ctor" [String s _, vs, _] ann) =
152 |       Ctor s (unquoteList (go inLambda) vs) ann
153 |     go inLambda e = error $ "can't unquote: " <> show e
154 | 
155 | quoteMaybe :: (a -> Expr b) -> Maybe a -> Expr b
156 | quoteMaybe f Nothing = Ctor "Nothing" [] Nothing
157 | quoteMaybe f (Just a) = Ctor "Just" [f a] Nothing
158 | 
159 | quoteList :: (a -> Expr b) -> [a] -> Expr b
160 | quoteList f [] = Ctor "Nil" [] Nothing
161 | quoteList f (a : as) = Ctor "Cons" [f a, quoteList f as] Nothing
162 | 
163 | quoteSrcInfo :: SrcInfo -> Expr b
164 | quoteSrcInfo (SrcInfo name line col) =
165 |   Ctor "SrcInfo"
166 |     [ String name Nothing
167 |     , Int line Nothing
168 |     , Int col Nothing
169 |     ]
170 |     Nothing
171 | 
172 | quote :: Expr SrcInfo -> Expr SrcInfo
173 | quote = go Nothing
174 |   where
175 |     go (Just n) (Bound n' a) | n' <= n = Bound n' a
176 |     go inLambda (Var s ann) =
177 |       Ctor "Var" [String s Nothing, quoteMaybe quoteSrcInfo ann] ann
178 |     go inLambda (Lam e ann) =
179 |       Ctor "Lam" [Lam (go ((+1) <$> inLambda <|> Just 0) e) Nothing, quoteMaybe quoteSrcInfo ann] ann
180 |     go inLambda (App f x ann) =
181 |       Ctor "App" [go inLambda f, go inLambda x, quoteMaybe quoteSrcInfo ann] ann
182 |     go inLambda (String s ann) =
183 |       Ctor "String" [String s Nothing, quoteMaybe quoteSrcInfo ann] ann
184 |     go inLambda (Int i ann) =
185 |       Ctor "Int" [Int i Nothing, quoteMaybe quoteSrcInfo ann] ann
186 |     go inLambda (Ctor n vs ann) =
187 |       Ctor "Ctor" [String n Nothing, quoteList (go inLambda) vs, quoteMaybe quoteSrcInfo ann] ann
188 |     go inLambda e = error $ "can't quote: " <> show e
189 | 
190 | initialCtxt :: [(String, Expr a)]
191 | initialCtxt =
192 |   [ ( "Var"
193 |     , Lam
194 |         (Lam
195 |            (Ctor "Var" [Bound 1 Nothing, Bound 0 Nothing] Nothing)
196 |            Nothing)
197 |         Nothing
198 |     )
199 |   , ( "Lam"
200 |     , Lam
201 |         (Lam
202 |            (Lam
203 |               (Ctor "Lam"
204 |                  [Bound 2 Nothing, Bound 1 Nothing, Bound 0 Nothing]
205 |                  Nothing)
206 |               Nothing)
207 |            Nothing)
208 |         Nothing
209 |     )
210 |   , ( "App"
211 |     , Lam
212 |         (Lam
213 |            (Lam
214 |               (Ctor "App"
215 |                  [Bound 2 Nothing, Bound 1 Nothing, Bound 0 Nothing]
216 |                  Nothing)
217 |               Nothing)
218 |            Nothing)
219 |         Nothing
220 |     )
221 |   , ( "String"
222 |     , Lam
223 |         (Lam
224 |            (Ctor "String" [Bound 1 Nothing, Bound 0 Nothing] Nothing)
225 |            Nothing)
226 |         Nothing
227 |     )
228 |   , ( "Int"
229 |     , Lam
230 |         (Lam
231 |            (Ctor "Int" [Bound 1 Nothing, Bound 0 Nothing] Nothing)
232 |            Nothing)
233 |         Nothing
234 |     )
235 |   , ( "Nil"
236 |     , Ctor "Nil" [] Nothing
237 |     )
238 |   , ( "Cons"
239 |     , Lam
240 |         (Lam
241 |            (Ctor "Cons" [Bound 1 Nothing, Bound 0 Nothing] Nothing)
242 |            Nothing)
243 |         Nothing
244 |     )
245 |   ]
246 | 
247 | data Value a
248 |   = VVar String (Maybe a)
249 |   | VBound Int (Maybe a)
250 |   | VLam [(String, Value a)] (Expr a) (Maybe a)
251 |   | VCtor String [Value a] (Maybe a)
252 |   | VString String (Maybe a)
253 |   | VInt Int (Maybe a)
254 |   deriving (Eq, Show)
255 | 
256 | eval :: [(String, Value SrcInfo)] -> Expr SrcInfo -> Value SrcInfo
257 | eval ctxt = go ctxt [] . splices ctxt
258 |   where
259 |     go :: [(String, Value SrcInfo)] -> [Value SrcInfo] -> Expr SrcInfo -> Value SrcInfo
260 |     go ctxt bound (Bound name _) = bound !! name
261 |     go ctxt bound (Var name _) =
262 |       case lookup name ctxt of
263 |         Nothing -> error $ "stuck: name not in context"
264 |         Just e -> e
265 |     go ctxt bound (Lam expr a) =
266 |       VLam ctxt expr a
267 |     go ctxt bound (Ctor n es a) = VCtor n (go ctxt bound <$> es) a
268 |     go ctxt bound (Unquote e _) = error "stuck: unquote not expanded"
269 |     go ctxt bound (Quote e _) = go ctxt bound $ quote e
270 |     go ctxt bound (App f x _) =
271 |       let
272 |         x' = go ctxt bound x
273 |       in
274 |         case go ctxt bound f of
275 |           VLam ctxt' e _ -> go ctxt' (x' : bound) e
276 |           _ -> error $ "stuck: application to non-function"
277 |     go _ _ (String s a) = VString s a
278 |     go _ _ (Int i a) = VInt i a
279 | 
280 | fromValue :: Value a -> Expr a
281 | fromValue e =
282 |   case e of
283 |     VVar a b -> Var a b
284 |     VBound a b -> Bound a b
285 |     VLam _ b c -> Lam b c
286 |     VCtor a b c -> Ctor a (fromValue <$> b) c
287 |     VString a b -> String a b
288 |     VInt a b -> Int a b
289 | 
290 | unquoteValue :: Value SrcInfo -> Expr SrcInfo
291 | unquoteValue = unquote . fromValue
292 | 
293 | splices :: [(String, Value SrcInfo)] -> Expr SrcInfo -> Expr SrcInfo
294 | splices ctxt (Lam expr a) = Lam (splices ctxt expr) a
295 | splices ctxt (Ctor n es a) = Ctor n (splices ctxt <$> es) a
296 | splices ctxt (Unquote e a) = unquoteValue $ eval ctxt e
297 | splices ctxt (App f x a) = App (splices ctxt f) (splices ctxt x) a
298 | splices ctxt e = e
299 | 


--------------------------------------------------------------------------------
/test/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# language LambdaCase #-}
 2 | {-# language TemplateHaskell #-}
 3 | {-# language BangPatterns #-}
 4 | module Main where
 5 | 
 6 | import Control.Monad.IO.Class (liftIO)
 7 | import Data.List (nub)
 8 | import Data.Traversable (for)
 9 | import Data.Void (Void)
10 | 
11 | import Hedgehog
12 |   ((===), Property, MonadGen, Size(..), property, discover, forAll
13 |   , checkSequential, annotateShow
14 |   )
15 | import qualified Hedgehog.Gen as Gen
16 | import qualified Hedgehog.Range as Range
17 | 
18 | import Syntax
19 | 
20 | genCtxt :: MonadGen m => m [(String, Value SrcInfo)]
21 | genCtxt = do
22 |   n <- Gen.integral (Range.constant 0 20)
23 |   names <-
24 |     nub <$>
25 |     Gen.list
26 |     (Range.singleton n)
27 |     (Gen.string (Range.constant 1 10) Gen.ascii)
28 |   go n [] names
29 |   where
30 |     go n seen [] = pure seen
31 |     go n seen (x : xs) = do
32 |       e <- Gen.scale (`div` Size n) (genExpr seen)
33 |       go n ((x, eval seen e) : seen) xs
34 | 
35 | genExpr :: MonadGen m => [(String, Value SrcInfo)] -> m (Expr SrcInfo)
36 | genExpr ctxt = go ctxt []
37 |   where
38 |     genLam ctxt bound = Lam <$> go ctxt (length bound : bound)
39 |     go ctxt bound =
40 |       Gen.recursive
41 |         Gen.choice
42 |         ([ Var <$> Gen.element (fst <$> ctxt) | not (null ctxt) ] ++
43 |          [ Bound <$> Gen.element bound | not (null bound) ] ++
44 |          [ String <$>
45 |            Gen.string (Range.constant 0 10) Gen.ascii
46 |          , Int <$>
47 |            Gen.int (Range.constant (-100) 100)
48 |          ])
49 |          [ genLam ctxt bound
50 |          , do
51 |              n <- Gen.integral (Range.constant 0 5)
52 |              Ctor <$>
53 |                Gen.string (Range.constant 1 10) Gen.ascii <*>
54 |                Gen.list
55 |                  (Range.singleton n)
56 |                  (Gen.scale (`div` Size n) $ go ctxt bound)
57 |          , App <$>
58 |            (Gen.scale (`div` 2) (genLam ctxt bound) <*> pure Nothing) <*>
59 |            Gen.scale (`div` 2) (go ctxt bound)
60 |          ] <*>
61 |         pure Nothing
62 | 
63 | prop_quote_unquote :: Property
64 | prop_quote_unquote =
65 |   property $ do
66 |     ctxt <- forAll genCtxt
67 |     expr <- forAll $ genExpr ctxt
68 |     fromValue (eval ctxt $ Unquote (Quote expr Nothing) Nothing) ===
69 |       fromValue (eval ctxt expr)
70 | 
71 | main :: IO Bool
72 | main = checkSequential $$(discover)
73 | 


--------------------------------------------------------------------------------