diff --git a/golden/adder/exec b/golden/exec/adder/exec similarity index 100% rename from golden/adder/exec rename to golden/exec/adder/exec diff --git a/golden/adder/source.scm b/golden/exec/adder/source.scm similarity index 100% rename from golden/adder/source.scm rename to golden/exec/adder/source.scm diff --git a/golden/apply-twice/exec b/golden/exec/apply-twice/exec similarity index 100% rename from golden/apply-twice/exec rename to golden/exec/apply-twice/exec diff --git a/golden/apply-twice/source.scm b/golden/exec/apply-twice/source.scm similarity index 100% rename from golden/apply-twice/source.scm rename to golden/exec/apply-twice/source.scm diff --git a/golden/apply2/exec b/golden/exec/apply2/exec similarity index 100% rename from golden/apply2/exec rename to golden/exec/apply2/exec diff --git a/golden/apply2/source.scm b/golden/exec/apply2/source.scm similarity index 100% rename from golden/apply2/source.scm rename to golden/exec/apply2/source.scm diff --git a/golden/arith/exec b/golden/exec/arith/exec similarity index 100% rename from golden/arith/exec rename to golden/exec/arith/exec diff --git a/golden/arith/source.scm b/golden/exec/arith/source.scm similarity index 100% rename from golden/arith/source.scm rename to golden/exec/arith/source.scm diff --git a/golden/callcc-constant/exec b/golden/exec/callcc-constant/exec similarity index 100% rename from golden/callcc-constant/exec rename to golden/exec/callcc-constant/exec diff --git a/golden/callcc-constant/source.scm b/golden/exec/callcc-constant/source.scm similarity index 100% rename from golden/callcc-constant/source.scm rename to golden/exec/callcc-constant/source.scm diff --git a/golden/callcc-discard/exec b/golden/exec/callcc-discard/exec similarity index 100% rename from golden/callcc-discard/exec rename to golden/exec/callcc-discard/exec diff --git a/golden/callcc-discard/source.scm b/golden/exec/callcc-discard/source.scm similarity index 100% rename from golden/callcc-discard/source.scm rename to golden/exec/callcc-discard/source.scm diff --git a/golden/callcc-nested1/exec b/golden/exec/callcc-nested1/exec similarity index 100% rename from golden/callcc-nested1/exec rename to golden/exec/callcc-nested1/exec diff --git a/golden/callcc-nested1/source.scm b/golden/exec/callcc-nested1/source.scm similarity index 100% rename from golden/callcc-nested1/source.scm rename to golden/exec/callcc-nested1/source.scm diff --git a/golden/callcc-nested2/exec b/golden/exec/callcc-nested2/exec similarity index 100% rename from golden/callcc-nested2/exec rename to golden/exec/callcc-nested2/exec diff --git a/golden/callcc-nested2/source.scm b/golden/exec/callcc-nested2/source.scm similarity index 100% rename from golden/callcc-nested2/source.scm rename to golden/exec/callcc-nested2/source.scm diff --git a/golden/factorial/exec b/golden/exec/factorial/exec similarity index 100% rename from golden/factorial/exec rename to golden/exec/factorial/exec diff --git a/golden/factorial/source.scm b/golden/exec/factorial/source.scm similarity index 100% rename from golden/factorial/source.scm rename to golden/exec/factorial/source.scm diff --git a/golden/false/exec b/golden/exec/false/exec similarity index 100% rename from golden/false/exec rename to golden/exec/false/exec diff --git a/golden/false/source.scm b/golden/exec/false/source.scm similarity index 100% rename from golden/false/source.scm rename to golden/exec/false/source.scm diff --git a/golden/fn-of-fn/exec b/golden/exec/fn-of-fn/exec similarity index 100% rename from golden/fn-of-fn/exec rename to golden/exec/fn-of-fn/exec diff --git a/golden/fn-of-fn/source.scm b/golden/exec/fn-of-fn/source.scm similarity index 100% rename from golden/fn-of-fn/source.scm rename to golden/exec/fn-of-fn/source.scm diff --git a/golden/if-false/exec b/golden/exec/if-false/exec similarity index 100% rename from golden/if-false/exec rename to golden/exec/if-false/exec diff --git a/golden/if-false/source.scm b/golden/exec/if-false/source.scm similarity index 100% rename from golden/if-false/source.scm rename to golden/exec/if-false/source.scm diff --git a/golden/if-number/exec b/golden/exec/if-number/exec similarity index 100% rename from golden/if-number/exec rename to golden/exec/if-number/exec diff --git a/golden/if-number/source.scm b/golden/exec/if-number/source.scm similarity index 100% rename from golden/if-number/source.scm rename to golden/exec/if-number/source.scm diff --git a/golden/if-true/exec b/golden/exec/if-true/exec similarity index 100% rename from golden/if-true/exec rename to golden/exec/if-true/exec diff --git a/golden/if-true/source.scm b/golden/exec/if-true/source.scm similarity index 100% rename from golden/if-true/source.scm rename to golden/exec/if-true/source.scm diff --git a/golden/lambda/exec b/golden/exec/lambda/exec similarity index 100% rename from golden/lambda/exec rename to golden/exec/lambda/exec diff --git a/golden/lambda/source.scm b/golden/exec/lambda/source.scm similarity index 100% rename from golden/lambda/source.scm rename to golden/exec/lambda/source.scm diff --git a/golden/let-fn/exec b/golden/exec/let-fn/exec similarity index 100% rename from golden/let-fn/exec rename to golden/exec/let-fn/exec diff --git a/golden/let-fn/source.scm b/golden/exec/let-fn/source.scm similarity index 100% rename from golden/let-fn/source.scm rename to golden/exec/let-fn/source.scm diff --git a/golden/letrec-fn/exec b/golden/exec/letrec-fn/exec similarity index 100% rename from golden/letrec-fn/exec rename to golden/exec/letrec-fn/exec diff --git a/golden/letrec-fn/source.scm b/golden/exec/letrec-fn/source.scm similarity index 100% rename from golden/letrec-fn/source.scm rename to golden/exec/letrec-fn/source.scm diff --git a/golden/square/exec b/golden/exec/square/exec similarity index 100% rename from golden/square/exec rename to golden/exec/square/exec diff --git a/golden/square/source.scm b/golden/exec/square/source.scm similarity index 100% rename from golden/square/source.scm rename to golden/exec/square/source.scm diff --git a/golden/true/exec b/golden/exec/true/exec similarity index 100% rename from golden/true/exec rename to golden/exec/true/exec diff --git a/golden/true/source.scm b/golden/exec/true/source.scm similarity index 100% rename from golden/true/source.scm rename to golden/exec/true/source.scm diff --git a/golden/reader/bool/read b/golden/reader/bool/read new file mode 100644 index 0000000..310c858 --- /dev/null +++ b/golden/reader/bool/read @@ -0,0 +1,9 @@ +[ Fix + ( SimpleF ( Boolean True ) ) +, Fix + ( SimpleF ( Boolean True ) ) +, Fix + ( SimpleF ( Boolean False ) ) +, Fix + ( SimpleF ( Boolean False ) ) +] \ No newline at end of file diff --git a/golden/reader/bool/source.scm b/golden/reader/bool/source.scm new file mode 100644 index 0000000..84af926 --- /dev/null +++ b/golden/reader/bool/source.scm @@ -0,0 +1 @@ +#t #true #f #false diff --git a/golden/reader/decimal/read b/golden/reader/decimal/read new file mode 100644 index 0000000..1b3cade --- /dev/null +++ b/golden/reader/decimal/read @@ -0,0 +1,15 @@ +[ Fix + ( SimpleF + ( Number 45.0 ) + ) +, Fix + ( SimpleF + ( Number 5667.0 ) + ) +, Fix + ( SimpleF + ( Number + ( -123.0 ) + ) + ) +] \ No newline at end of file diff --git a/golden/reader/decimal/source.scm b/golden/reader/decimal/source.scm new file mode 100644 index 0000000..58684bc --- /dev/null +++ b/golden/reader/decimal/source.scm @@ -0,0 +1 @@ +45 +5667 -123 diff --git a/golden/reader/delimited-identifier/read b/golden/reader/delimited-identifier/read new file mode 100644 index 0000000..b84aa6a --- /dev/null +++ b/golden/reader/delimited-identifier/read @@ -0,0 +1,5 @@ +[ Fix + ( SimpleF + ( Symbol "aaaa bc" ) + ) +] \ No newline at end of file diff --git a/golden/reader/delimited-identifier/source.scm b/golden/reader/delimited-identifier/source.scm new file mode 100644 index 0000000..e067c11 --- /dev/null +++ b/golden/reader/delimited-identifier/source.scm @@ -0,0 +1 @@ +|aaaa bc| diff --git a/golden/reader/empty/read b/golden/reader/empty/read new file mode 100644 index 0000000..0637a08 --- /dev/null +++ b/golden/reader/empty/read @@ -0,0 +1 @@ +[] \ No newline at end of file diff --git a/golden/reader/empty/source.scm b/golden/reader/empty/source.scm new file mode 100644 index 0000000..e69de29 diff --git a/golden/reader/peculiar-identifier/read b/golden/reader/peculiar-identifier/read new file mode 100644 index 0000000..ef7025d --- /dev/null +++ b/golden/reader/peculiar-identifier/read @@ -0,0 +1,9 @@ +[ Fix + ( SimpleF + ( Symbol "+" ) + ) +, Fix + ( SimpleF + ( Symbol "-" ) + ) +] \ No newline at end of file diff --git a/golden/reader/peculiar-identifier/source.scm b/golden/reader/peculiar-identifier/source.scm new file mode 100644 index 0000000..c52cc3a --- /dev/null +++ b/golden/reader/peculiar-identifier/source.scm @@ -0,0 +1 @@ ++ - diff --git a/golden/reader/string-line-continuation/read b/golden/reader/string-line-continuation/read new file mode 100644 index 0000000..3795d82 --- /dev/null +++ b/golden/reader/string-line-continuation/read @@ -0,0 +1,5 @@ +[ Fix + ( SimpleF + ( String "가나다라마바" ) + ) +] \ No newline at end of file diff --git a/golden/reader/string-line-continuation/source.scm b/golden/reader/string-line-continuation/source.scm new file mode 100644 index 0000000..0c26be9 --- /dev/null +++ b/golden/reader/string-line-continuation/source.scm @@ -0,0 +1,2 @@ +"가나다\ + 라마바" diff --git a/golden/reader/string/read b/golden/reader/string/read new file mode 100644 index 0000000..71ddf65 --- /dev/null +++ b/golden/reader/string/read @@ -0,0 +1,5 @@ +[ Fix + ( SimpleF + ( String "가나다라" ) + ) +] \ No newline at end of file diff --git a/golden/reader/string/source.scm b/golden/reader/string/source.scm new file mode 100644 index 0000000..9351d56 --- /dev/null +++ b/golden/reader/string/source.scm @@ -0,0 +1 @@ +"가나다라" diff --git a/golden/reader/typical-identifier/read b/golden/reader/typical-identifier/read new file mode 100644 index 0000000..31a3925 --- /dev/null +++ b/golden/reader/typical-identifier/read @@ -0,0 +1,29 @@ +[ Fix + ( SimpleF + ( Symbol "abc" ) + ) +, Fix + ( SimpleF + ( Symbol "balahwa$" ) + ) +, Fix + ( SimpleF + ( Symbol "x!!!" ) + ) +, Fix + ( SimpleF + ( Symbol "z" ) + ) +, Fix + ( SimpleF + ( Symbol "z123" ) + ) +, Fix + ( SimpleF + ( Symbol "나는너무졸리다" ) + ) +, Fix + ( SimpleF + ( Symbol "學" ) + ) +] \ No newline at end of file diff --git a/golden/reader/typical-identifier/source.scm b/golden/reader/typical-identifier/source.scm new file mode 100644 index 0000000..bfcfcf8 --- /dev/null +++ b/golden/reader/typical-identifier/source.scm @@ -0,0 +1 @@ +abc balahwa$ x!!! z z123 나는너무졸리다 學 diff --git a/gyehoek.cabal b/gyehoek.cabal index e1ec645..04b9560 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -77,12 +77,16 @@ library , base ^>=4.21.2.0 , binary , bytestring + , comonad , containers + , data-fix , deepseq + , deriving-compat , effectful , effectful-core , effectful-plugin , filepath + , free , generic-lens , hashable , invertible-grammar @@ -114,6 +118,8 @@ test-suite test hs-source-dirs: test main-is: Main.hs build-tool-depends: tasty-discover:tasty-discover + + -- cabal-fmt: expand test -Main other-modules: Gyehoek.Test.CPS.Eval Gyehoek.Test.CPS.Stackify @@ -133,6 +139,7 @@ test-suite test , generic-lens , gyehoek , lens + , pretty-simple , process-extras , sexp-grammar , tasty diff --git a/src/Gyehoek/Prelude.hs b/src/Gyehoek/Prelude.hs index 10e66a8..d9a6022 100644 --- a/src/Gyehoek/Prelude.hs +++ b/src/Gyehoek/Prelude.hs @@ -21,7 +21,7 @@ module Gyehoek.Prelude import Control.Lens import Data.List (List) import Data.Text (Text) -import Effectful (Eff, runEff, runPureEff, (:>)) +import Effectful import GHC.Generics (Generic) import Data.Data (Data) import Control.DeepSeq (NFData) diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index 12a0530..0eb5e4d 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/src/Gyehoek/Sexp/Read.hs @@ -1,4 +1,133 @@ module Gyehoek.Sexp.Read - ( + ( readFile ) where +import Text.Megaparsec +import Text.Megaparsec.Char hiding (string) +import qualified Text.Megaparsec.Char.Lexer as L +import Data.Void (Void) +import Gyehoek.Sexp.Syntax +import Gyehoek.Prelude hiding (Simple, (:<)) +import qualified Data.Text.IO as T +import System.IO (stderr, hPutStrLn) +import Prelude hiding (readFile) +import Data.Functor (($>)) +import qualified Data.Text as T +import Data.Char (GeneralCategory(..), generalCategory) +import Control.Exception hiding (try) +import Data.Scientific (Scientific) + + +-- i'm lazy +newtype ReaderError = MkReaderError String + deriving (Show) + +instance Exception ReaderError where + displayException (MkReaderError x) = x + +readFile :: IOE :> es => FilePath -> Eff es (List Datum) +readFile f = do + s <- liftIO . T.readFile $ f + case runParser file f s of + Right x -> pure x + Left e -> do + -- liftIO . hPutStrLn stderr . errorBundlePretty $ e + liftIO . throw . MkReaderError . errorBundlePretty $ e + +type P = Parsec Void Text + + +--- lexer helpers + +-- TODO: check R⁷RS +sc :: P () +sc = L.space space1 + (L.skipLineComment ";") + (L.skipBlockCommentNested "#|" "|#") + +lexeme :: P a -> P a +lexeme = L.lexeme sc + +verb :: Text -> P Text +verb = L.symbol sc + + +--- tokens + +identifier :: P Text +identifier = label "identifier" . lexeme . choice $ + [ typical-- , delimited, peculiar + ] + where + typical = T.cons <$> initial <*> subsequent + where + subsequent = takeWhileP Nothing identChar + initial = satisfy \c -> + identChar c && not (c `hasCategory` + [DecimalNumber,SpacingCombiningMark,EnclosingMark]) + delimited = _ + peculiar = _ + + hasCategory c xs = generalCategory c `elem` xs + identChar c = c `hasCategory` + [ UppercaseLetter, LowercaseLetter, TitlecaseLetter, ModifierLetter + , OtherLetter, SpacingCombiningMark, EnclosingMark, DecimalNumber + , LetterNumber, OtherNumber, DashPunctuation, ConnectorPunctuation + , OpenPunctuation, CurrencySymbol, OtherPunctuation, MathSymbol + , ModifierSymbol, OtherSymbol, PrivateUse ] + || c == '\x200c' || c == '\x200d' + +boolean :: P Bool +boolean = label "boolean" . lexeme $ choice + [ ("#true" <|> "#t") $> True + , ("#false" <|> "#f") $> False + ] + +symbol = identifier + +number :: P Scientific +number = label "number" . lexeme $ num + where + num = L.signed (pure ()) L.decimal + -- prefix r = _ + -- radix = \case + -- 2 -> "#b" + -- 8 -> "#o" + -- 10 -> "" <|> "#d" + -- 16 -> "#x" + +lparen = lexeme $ char '(' +rparen = lexeme $ char ')' + +string :: P Text +string = label "string" . lexeme $ + char '"' *> (T.pack <$> many element) <* char '"' + where + element = choice + [ satisfy (\c -> c /= '"' && c /= '\\') + , "\\\"" $> '"' + , "\\\\" $> '\\' + ] + + + +file :: P (List Datum) +file = many datum <* eof + +datum :: P Datum +datum = choice + [ Fix . SimpleF <$> simpleDatum + -- , Fix . CompoundF <$> compoundDatum + -- , labeled + -- , labelRef + ] + +simpleDatum :: P Simple +simpleDatum = choice + [ Boolean <$> boolean + , Number <$> try number + -- , Character <$> character + , String <$> string + , Symbol <$> symbol + -- , Bytevector <$> bytevector + ] diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index 8afba00..e63420c 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} module Gyehoek.Sexp.Syntax ( DatumF(..) , Simple(..) @@ -6,12 +7,22 @@ module Gyehoek.Sexp.Syntax , Prefix(..) , Delimiter(..) , Label(..) + , SourcePos(..) + , Datum + , Cofree((:<)) + , Fix(..) ) where import Language.Haskell.TH.Syntax (Lift) import Data.Scientific (Scientific) import Data.ByteString (ByteString) -import Gyehoek.Prelude hiding (Simple) +import Gyehoek.Prelude hiding ((:<), Simple) +import Text.Megaparsec.Pos (SourcePos(..)) +import Control.Comonad.Cofree (Cofree((:<))) +import Data.Fix (Fix (..)) +import Data.Functor.Foldable +import Text.Show.Deriving (deriveShow1) +import qualified Control.Comonad.Trans.Cofree as F data DatumF a @@ -19,16 +30,16 @@ data DatumF a | CompoundF (CompoundF a) | LabeledF Label a | LabelRefF Label - deriving stock (Show, Eq, Data, Generic, Lift) + deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable) deriving anyclass (NFData) data Simple - = SimpleBool Bool - | SimpleNumber Scientific - | SimpleChar Char - | SimpleString Text - | SimpleSymbol Text - | SimpleBytevector ByteString + = Boolean Bool + | Number Scientific + | Character Char + | String Text + | Symbol Text + | Bytevector ByteString deriving stock (Show, Eq, Data, Generic, Lift) deriving anyclass (NFData) @@ -37,7 +48,7 @@ data CompoundF a | DotListF (NonEmpty a) a | VectorF (List a) | AbbrevF Prefix a - deriving stock (Show, Eq, Data, Generic, Lift) + deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable) deriving anyclass (NFData) data Prefix @@ -56,3 +67,10 @@ newtype Label = MkLabel Natural deriving stock (Data, Generic, Lift) deriving newtype (Eq, Ord, Show) deriving anyclass (NFData) + +deriveShow1 ''CompoundF +deriveShow1 ''DatumF + + + +type Datum = Fix DatumF diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index bd83f50..5085890 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/test/Gyehoek/Test/Golden.hs @@ -16,6 +16,10 @@ import Data.Text qualified as T import System.Exit (ExitCode(..)) import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause) import Control.DeepSeq (($!!)) +import Text.Pretty.Simple (pShow, pShowNoColor) +import Control.Lens (strict, view) +import Gyehoek.Sexp.Read qualified as Read +import Effectful brokenWasmTests :: List String @@ -31,12 +35,17 @@ brokenStackifyTests = -- , "callcc-nested1" -- requires closure-conversion -- ] +brokenReaderTests = + [ "delimited-identifier" + , "string-line-continuation" + ] + test_root :: IO TestTree test_root = do - all_cases <- listDirectory "golden" + all_cases <- listDirectory "golden/exec" let tests = all_cases - & fmap ("golden") - testGroup "golden" <$> sequenceA + & fmap ("golden/exec") + testGroup "execution" <$> sequenceA [ ignoreTestBecause "wasm codegen is on the backburner" <$> wasmTests tests , stackifyTests tests @@ -48,7 +57,7 @@ wasmTests :: List FilePath -> IO TestTree wasmTests files = do cmd <- getEnvDefault "GYEHOEK_RUNTIME" "runtime/target/debug/gyehoek-runtime" - pure $ testGroup "wasm execution" $ files <&> \test -> + pure $ testGroup "wasm" $ files <&> \test -> let testname = takeFileName test scmfile = test "source.scm" resultfile = test "exec" @@ -64,7 +73,7 @@ wasmTests files = do stackifyTests :: List FilePath -> IO TestTree stackifyTests files = do - pure $ testGroup "stackified execution" $ files <&> \test -> + pure $ testGroup "stackified" $ files <&> \test -> let testname = takeFileName test scmfile = test "source.scm" resultfile = test "exec" @@ -81,3 +90,22 @@ stackifyTests files = do resultfile action printProcResult + +test_reader :: IO TestTree +test_reader = do + all_cases <- listDirectory "golden/reader" + let tests = all_cases + & fmap ("golden/reader") + pure . testGroup "reader" $ tests <&> \test -> + let testname = takeFileName test + scmfile = test "source.scm" + resultfile = test "read" + action = runEff $ Read.readFile scmfile + in maybeBroken testname brokenReaderTests $ goldenVsAction + testname + resultfile + action + (view strict . pShowNoColor) + +-- readTests files = pure . testGroup "reader" $ files <&> \test -> +-- let