diff --git a/test/Scripts.hs b/test/Scripts.hs index 178b850..76e8dba 100644 --- a/test/Scripts.hs +++ b/test/Scripts.hs @@ -2,27 +2,17 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskellQuotes #-} -module Scripts - ( Script (..), - mkScript, - ) -where +module Scripts where + +-- ( Script (..), +-- mkScript, +-- ) -------------------------------------------------------------------------------- import Control.Applicative (asum) import Control.Monad (void) import Data.Attoparsec.Text - ( Parser, - endOfInput, - isEndOfLine, - many', - many1, - parseOnly, - satisfy, - skipSpace, - takeWhile1, - ) import Data.Text (Text) import Data.Text qualified as Text import Language.Haskell.TH.Quote (QuasiQuoter (..)) @@ -30,9 +20,8 @@ import Language.Haskell.TH.Syntax (Lift) -------------------------------------------------------------------------------- -newtype Script = Script [(Text, [Text])] - deriving stock (Lift) - deriving newtype (Show, Read, Eq, Ord) +data LineType = StartInput Text | StartOutput Text | Continue Text + deriving (Show) end :: Parser () end = asum [void (satisfy isEndOfLine), endOfInput] @@ -40,15 +29,50 @@ end = asum [void (satisfy isEndOfLine), endOfInput] line :: Parser Text line = takeWhile1 (not . isEndOfLine) <* end -inputOutputs :: Parser (Text, [Text]) -inputOutputs = do - skipSpace - input <- ">>>" *> line - outputs <- many' (skipSpace *> "<<<" *> line) - pure (input, outputs) +parseLineType :: Parser [LineType] +parseLineType = do + many1 $ + asum + [ fmap StartInput (skipSpace *> void ">>>" *> line), + fmap StartOutput (skipSpace *> void "<<<" *> line), + fmap Continue (skipSpace *> line) + ] + +data History = Input Text | Output Text + deriving (Show) + +following :: [LineType] -> (Text, [LineType]) +following [] = ("", []) +following (Continue l : ls) = + let (a, b) = following ls + in ("\n" <> l <> a, b) +following ls = ("", ls) + +aggregateLines :: [LineType] -> [History] +aggregateLines [] = [] +aggregateLines (StartInput l0 : ls) = + let (a, b) = following ls + in Input (l0 <> a) : aggregateLines b +aggregateLines (StartOutput l0 : ls) = + let (a, b) = following ls + in Output (l0 <> a) : aggregateLines b +-- ignore lines before the first >>> or <<< +aggregateLines (Continue _ : ls) = aggregateLines ls + +aggregateScript :: [History] -> Script +aggregateScript history = Script $ reverse $ go history [] + where + go [] res = res + go (Input x : xs) res = go xs ((x, []) : res) + go (Output _ : _) [] = error "Recieved an output without an input" + go (Output o : xs) ((i, os) : res) = go xs ((i, o : os) : res) + +newtype Script = Script [(Text, [Text])] + deriving stock (Lift) + deriving newtype (Show, Read, Eq, Ord) parseScript :: Parser Script -parseScript = Script <$> many1 inputOutputs +parseScript = fmap (aggregateScript . aggregateLines) parseLineType mkScript :: QuasiQuoter mkScript = @@ -58,5 +82,5 @@ mkScript = quoteType _ = error "'script' does not support quoting types" quoteDec _ = error "'script' does not support quoting declarations" quoteExp str = case parseOnly parseScript (Text.pack str) of - Left _err -> error $ str <> " is not a valid script" + Left err -> error err Right result -> [|result|] diff --git a/test/Spec.hs b/test/Spec.hs index 469da2f..35da4bc 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -98,3 +98,38 @@ sessionizedBotSpec = |] result <- runTestScript scenario $ fixBot bot mempty result `shouldBe` scenario + + it "preserves bot behavior" $ do + let scenario = + [mkScript| + >>>new + <<>>use 0: (1 + 2) + <<>>new + <<>>new + <<>>use 0: x := (1 + 2) + <<>>use 1: x := 42 + <<>>use 0: x + <<>>use 1: x + <<