tests

2026-07-11 16:25:58 -06:00
parent 475f0a7f68
commit d71d78c68f
24 changed files with 458 additions and 120 deletions
@@ -0,0 +1,213 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Gyehoek.Scheme.Syntax
+  ( Name(..)
+  , Prim(..)
+  , Lit(..)
+  , Def(..)
+  , Exp(..)
+  , Sexp(..)
+  , Program(..)
+  , CommandOrDef(..)
+  , primSexpIso
+  , pattern Void
+  )
+  where
+
+import Data.Text (Text)
+import Data.List (List)
+import Language.SexpGrammar
+  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
+import Language.SexpGrammar qualified as Sexp
+import Language.Sexp.Located qualified as S
+import Language.SexpGrammar.Generic
+import GHC.Generics
+import Prelude hiding ((.), id)
+import Control.Category
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Gyehoek.Sexp qualified
+import Gyehoek.GenSym (Gen)
+import Control.Lens
+import Data.String (IsString)
+import Data.Hashable (Hashable)
+import Control.Lens.Unsound (prismSum)
+
+
+newtype Name = MkName { getName :: Text }
+  deriving newtype (Show, Eq, IsString, Gen, Hashable)
+  deriving stock (Generic)
+
+data Prim e
+  = PrimAdd e e
+  | PrimSub e e
+  | PrimMul e e
+  | PrimDiv e e
+  | PrimCons e e
+  | PrimCar e
+  | PrimCdr e
+  | PrimImmediateP e
+  | PrimConsP e
+  | PrimIntegerP e
+  | PrimWrite e
+  | PrimZeroP e
+  | PrimNewline
+  deriving (Show, Generic, Functor, Foldable, Traversable)
+
+instance Each (Prim e) (Prim e') e e'
+
+data Lit
+  = LitInt Int
+  | LitNil
+  | LitBool Bool
+  | LitString Text
+  | LitQuote Sexp
+  deriving (Show, Generic)
+
+pattern Void :: Lit
+pattern Void = LitNil
+
+data Def
+  = DefConstant Name Exp
+  | DefProcedure Name (List Name) (List Exp)
+  deriving (Show, Generic)
+
+data Exp
+  = ExpLet (NonEmpty (Name, Exp)) Exp
+  | ExpPrim (Prim Exp)
+  | ExpBegin (List Exp)
+  | ExpIf Exp Exp Exp
+  | ExpLit Lit
+  | ExpLambda (List Name) Exp
+  | ExpVar Name
+  | ExpApply Exp (List Exp)
+  deriving (Show, Generic)
+
+data Sexp
+  = SexpCons Sexp Sexp
+  | SexpSymbol Text
+  | SexpLit Lit
+  deriving (Show, Generic)
+
+data CommandOrDef
+  = Command Exp
+  | Definition Def
+  | Begin (List CommandOrDef)
+  deriving (Show, Generic)
+
+data Program = MkProgram
+  { commandsAndDefs :: List CommandOrDef
+  }
+  deriving (Show, Generic)
+
+instance Each Program Program (Either Exp Def) (Either Exp Def) where
+  each = #commandsAndDefs . each . go
+    where
+      inj = either Command Definition
+      toeither (Command e) = Left e
+      toeither (Definition d) = Right d
+      go :: Traversal' CommandOrDef (Either Exp Def)
+      go k (Command e) = inj <$> k (Left e)
+      go k (Definition d) = inj <$> k (Right d)
+      go k (Begin xs) = Begin <$> traverse (go k) xs
+
+
+
+instance SexpIso Name where
+  sexpIso = symbol >>> Sexp.partialOsi f g
+    where
+      f = Right . MkName
+      g (MkName s) = s
+
+primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
+primSexpIso namefn a = match
+    $ With (. binop "+")
+    $ With (. binop "-")
+    $ With (. binop "*")
+    $ With (. binop "/")
+    $ With (. binop "cons")
+    $ With (. unop "car")
+    $ With (. unop "cdr")
+    $ With (. unop "immediate?")
+    $ With (. unop "cons?")
+    $ With (. unop "integer?")
+    $ With (. unop "write")
+    $ With (. unop "zero?")
+    $ With (. nullop "newline")
+    $ End
+    where
+      idn s = el (sym (namefn s))
+      nullop s = list $ idn s
+      unop s = list $ idn s >>> el a
+      binop s = list $ idn s >>> el a >>> el a
+
+instance SexpIso a => SexpIso (Prim a) where
+  -- sexpIso = primSexpIso ("prim:"<>) sexpIso
+  sexpIso = primSexpIso id sexpIso
+
+instance SexpIso Lit where
+  sexpIso = match
+    $ With (. sexpIso)
+    $ With (. sym "nil")
+    $ With (. bool)
+    $ With (. sexpIso)
+    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
+    $ End
+    where
+      bool :: Sexp.SexpGrammar Bool
+      bool = Sexp.hashed $ Sexp.partialOsi f g
+        where
+          f (S.Symbol ("t";"true")) = Right True
+          f (S.Symbol ("f";"false")) = Right False
+          f _ = Left $ Sexp.expected "bool"
+          g True = S.Symbol "true"
+          g False = S.Symbol "false"
+
+instance SexpIso Sexp where
+  sexpIso = match
+    $ With (\cons -> cons . Gyehoek.Sexp.todo)
+    $ With (\s -> s . symbol)
+    $ With (\lit -> lit . sexpIso)
+    $ End
+
+instance SexpIso Def where
+  sexpIso = match
+    $ With (. defconst)
+    $ With (. defun)
+    $ End
+    where
+      defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
+      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
+      args = list $ el sexpIso >>> rest sexpIso
+  
+instance SexpIso Exp where
+  sexpIso = match
+    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. sexpIso)
+    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
+    $ With (. if_)
+    $ With (. sexpIso)
+    $ With (. lam)
+    $ With (. sexpIso)
+    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
+    $ End
+    where
+      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
+      lam = list
+        ( el Gyehoek.Sexp.lambdaKeyword
+          >>> el (sexpIso @(List Name))
+          >>> el sexpIso )
+
+instance SexpIso CommandOrDef where
+  sexpIso = match
+    $ With (\_Command -> _Command . sexpIso)
+    $ With (\_Definition -> _Definition . sexpIso)
+    $ With (\_Begin -> _Begin . bgn)
+    $ End
+    where
+      bgn = list $ el (sym "begin") >>> rest sexpIso