diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 73961dc..e57d874 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -42,6 +42,7 @@ import Gyehoek.Sexp qualified import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void, getName) import Data.List (List) import GHC.Generics (Generic) +import Data.Generics.Labels () import Language.SexpGrammar.Generic import Control.Category import Control.Lens hiding (op) @@ -79,7 +80,10 @@ data Abs | AbsLambda Lambda deriving (Show, Generic, Data, Eq) +pattern AbsKappa' :: [Name] -> Exp -> Abs pattern AbsKappa' xs e = AbsKappa (MkKappa xs e) + +pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail) data Exp diff --git a/src/Gyehoek/GenSym.hs b/src/Gyehoek/GenSym.hs index 1e4cd2d..7a0f06e 100644 --- a/src/Gyehoek/GenSym.hs +++ b/src/Gyehoek/GenSym.hs @@ -8,7 +8,6 @@ import Effectful.Dispatch.Dynamic import Effectful import Data.String (IsString(fromString)) import Data.Text (Text) -import qualified Data.Text.Short as ST class Gen a where diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index cd8a956..b57f798 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -34,7 +34,6 @@ 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 Effectful import GHC.Generics (Generic) @@ -44,6 +43,7 @@ import Data.List.NonEmpty (NonEmpty) import Gyehoek.Sexp qualified import Gyehoek.GenSym (Gen) import Control.Lens +import Data.Generics.Labels () import Data.String (IsString) import Data.Hashable (Hashable) import Data.Data (Data) @@ -281,6 +281,5 @@ readProgram fp = runFileSystem $ Gyehoek.Sexp.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h >>= either error (pure . MkProgram) -readExp :: IOE :> es => FilePath -> Eff es Program -readExp fp = readProgram fp <&> - (^?! (#commandsAndDefs . _head . _Comm)) +readExp :: IOE :> es => FilePath -> Eff es Exp +readExp fp = readProgram fp <&> (^?! #commandsAndDefs . _head . #Command) diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index 7f62fcc..2e12437 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -25,8 +25,6 @@ module Gyehoek.Sexp , lambdaKeyword , encodePrettyWith , encodePretty - , UglySexpIso(..) - , AsSexpIso(..) , SpliceSexp(..) , parseSexpsWithPos , parseSexpWithPos @@ -56,41 +54,26 @@ import Data.Text (Text) import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp) import Language.SexpGrammar qualified as Sexp import Language.Sexp qualified as S -import Language.SexpGrammar.Generic import Data.InvertibleGrammar.Base qualified as IGB import Data.InvertibleGrammar qualified as IG import Data.InvertibleGrammar.Base ((:-)((:-))) import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.List.NonEmpty qualified as NE import Data.List (List, groupBy) import Data.Text.Encoding -import Data.Either (either) import GHC.Generics (Generic) import Control.Lens hiding (para) -import Data.Generics.Labels -import System.Process -import GHC.IO.Unsafe (unsafePerformIO) -import qualified Data.Text.IO as TIO import Control.Monad (join) import qualified Language.Sexp.Located as SL -import Data.Void (absurd, Void) -import Data.Coerce (coerce) -import qualified Data.Map +import Data.Void (absurd) import Language.Haskell.TH.Quote -import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE, Q, Code, unTypeCode) +import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, Q, Code, unTypeCode) import qualified Data.Text as T import qualified Control.Category import Data.Data (Data (..), Typeable, cast) import Language.Haskell.TH.Syntax (lift, Lift, liftData) -import GHC.IsList (fromList) -import Data.Functor.Foldable (cata, para, embed) -import Data.Functor.Classes (Show1(..)) +import Data.Functor.Foldable (cata) import Data.Vector (Vector) import Numeric.Natural (Natural) -import Data.Maybe (fromMaybe) -import Control.Applicative (Alternative((<|>))) -import Debug.Pretty.Simple -import qualified Data.Vector as V import qualified Data.Vector.Strict import Data.Function (on) import Data.String (IsString (fromString)) @@ -199,11 +182,6 @@ let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e) data DotList a = MkDotList (NonEmpty a) a deriving (Show, Generic) -dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _ -dotlist x = list $ rest $ coproduct - [ x >>> _ - ] - -- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩. prefixSugar :: Text -> Prefix @@ -217,7 +195,7 @@ prefixSugar name prefix e = coproduct ] todo :: Grammar p (Sexp :- t) t' -todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g +todo = IGB.Flip (IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g where f _ = Left $ unexpected "todo" g _ = Left $ unexpected "todo" @@ -280,31 +258,6 @@ headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2 -class UglySexpIso a where - uglySexpIso :: SexpGrammar a - -newtype AsSexpIso a = AsSexpIso a -newtype AsUglySexpIso a = AsUglySexpIso a - -asSexpIso :: Grammar p (a :- t) (AsSexpIso a :- t) -asSexpIso = Sexp.iso AsSexpIso (\(AsSexpIso x) -> x) - -instance UglySexpIso a => SexpIso (AsUglySexpIso a) where - sexpIso = uglySexpIso @a >>> Sexp.iso coerce coerce - -instance SexpIso a => UglySexpIso (AsSexpIso a) where - uglySexpIso = sexpIso >>> Sexp.iso (\x -> AsSexpIso x) (\(AsSexpIso x) -> x) - --- why not work --- deriving via AsSexpIso Text instance UglySexpIso Text - -instance UglySexpIso Text where uglySexpIso = sexpIso -instance UglySexpIso Integer where uglySexpIso = sexpIso -instance UglySexpIso Int where uglySexpIso = sexpIso -instance UglySexpIso Bool where uglySexpIso = sexpIso -instance UglySexpIso Double where uglySexpIso = sexpIso -instance UglySexpIso () where uglySexpIso = sexpIso - instance SexpIso Sexp where sexpIso = Control.Category.id @@ -334,8 +287,11 @@ toSexp = either error id . Sexp.toSexp sexpIso toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp toSexps = foldMap \x -> [toSexp x] +pattern Unquote :: Text -> Sexp pattern Unquote x = SL.Modified Hash (SL.BraceList [SL.Symbol x]) + +pattern UnquoteSplicing :: Text -> Sexp pattern UnquoteSplicing x = SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x])) diff --git a/test/Gyehoek/Test/CPS/Stackify.hs b/test/Gyehoek/Test/CPS/Stackify.hs index 0d67087..d6e0d83 100644 --- a/test/Gyehoek/Test/CPS/Stackify.hs +++ b/test/Gyehoek/Test/CPS/Stackify.hs @@ -8,7 +8,6 @@ import Data.List (List) import Gyehoek.CPS.Syntax (cps) import Gyehoek.GenSym (runGenSym) import Effectful -import Test.Tasty.ExpectedFailure (expectFail) root :: IO TestTree diff --git a/test/Gyehoek/Test/CPS/Syntax.hs b/test/Gyehoek/Test/CPS/Syntax.hs index 6393c0b..a49791c 100644 --- a/test/Gyehoek/Test/CPS/Syntax.hs +++ b/test/Gyehoek/Test/CPS/Syntax.hs @@ -3,12 +3,9 @@ module Gyehoek.Test.CPS.Syntax (root) where import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit -import Language.Sexp.Located qualified as SL import Language.SexpGrammar () import Gyehoek.CPS.Syntax (cps) import Gyehoek.CPS.Syntax qualified as Sut -import Data.Function (on) -import Gyehoek.Test.Sexp (equivto) root :: IO TestTree diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs index d40f551..23aa0cc 100644 --- a/test/Gyehoek/Test/Stack/VM.hs +++ b/test/Gyehoek/Test/Stack/VM.hs @@ -5,8 +5,6 @@ import Test.Tasty.HUnit import Gyehoek.Stack.Syntax import Gyehoek.Stack.VM qualified as Sut import Data.List (List) -import Control.Lens -import Data.Generics.Labels root :: IO TestTree @@ -31,8 +29,6 @@ lit_int = testCase "lit int" do ] ] -vlb = ValImm . ImmLabel - procedure = testGroup "procedure" [ testCase "return constant" do evalsTo [ObjImm (ImmInt 123)] @@ -66,7 +62,7 @@ procedure = testGroup "procedure" ] ] , testCase "factorial" do - let fac = + let fac n = [ MkBlock "fac" ["n"] [ Prim "x0" $ PrimZeroP (ValReg "n") , If (ValReg "x0") @@ -85,17 +81,12 @@ procedure = testGroup "procedure" , PopCont "ktail" , Call (ValReg "ktail") [ValReg "x3"] ] + , MkBlock "main" [] + [ Call (ValLabel "fac") [ValImm (ImmInt n)] + ] ] - evalsTo [ObjImm (ImmInt 1)] $ - [ MkBlock "main" [] - [ Call (ValLabel "fac") [ValImm (ImmInt 0)] - ] - ] ++ fac - evalsTo [ObjImm (ImmInt 720)] $ - [ MkBlock "main" [] - [ Call (ValLabel "fac") [ValImm (ImmInt 6)] - ] - ] ++ fac + evalsTo [ObjImm (ImmInt 1)] $ fac 0 + evalsTo [ObjImm (ImmInt 720)] $ fac 6 ] prims = testGroup "prims"