boilerplate-0.0.2: test/Boilerplate/RuleParserTests.hs

{-# LANGUAGE OverloadedStrings #-}

module Boilerplate.RuleParserTests where

import qualified Data.Text as T
import Boilerplate.Types
import Boilerplate.RuleParser
import Test.Tasty.Hspec
import Data.Either.Extra
import Text.Parsec (parse)
import Text.Parsec.Text (parseFromFile)

-- uses parsec
parseRule :: String -> Either String Rule
parseRule = mapLeft show . parse ruleParser "test" . T.pack

parseRuleFile :: FilePath -> IO (Either String Rule)
parseRuleFile file = do
  res <- parseFromFile ruleParser file
  pure $ mapLeft show res

-- uses ReadP, no errors but principle of least power
-- import Text.ParserCombinators.ReadP (readP_to_S)
-- parseRule :: String -> Maybe Rule
-- parseRule txt = listToMaybe $ fst <$> (filter (null . snd) . readP_to_S ruleParser $ txt)

shouldParseTo :: HasCallStack => String -> [Atom] -> Expectation
shouldParseTo input expected = (parseRule input) `shouldBe` (Right $ Rule expected)

shouldNotParse :: HasCallStack => String -> Expectation
shouldNotParse input = (parseRule input) `shouldSatisfy` isLeft

spec_rules :: Spec
spec_rules = do
  it "should parse plain text" $ do
    "hello world" `shouldParseTo` [Raw "hello world"]
  it "should parse escaped plain text" $ do
    "hello \\{world\\}" `shouldParseTo` [Raw "hello {world}"]
  it "should not parse unescaped plain text" $ do
    shouldNotParse "hello {world}"
  it "should parse Cons inside Product" $ do
    "{Product {Cons} = foo}" `shouldParseTo` [Product [Cons, Raw " = foo"]]
  it "should parse raw text inside a Product" $ do
    "{Product\n   foo :: {Type}}" `shouldParseTo` [Product [Raw "   foo :: ", Type]]
  it "should not parse Param outside a Field" $ do
    shouldNotParse "{Param} = foo"
    shouldNotParse "{Product {Param}} = foo"
    "{Product\n{Field {{Param}}{}}} = foo" `shouldParseTo`
      [Product [Field [] [] [Param 1] "" ""], Raw " = foo"]
  it "should parse long form Field inside Product" $ do
    "{Product  {Field {}{<$>}{v .: }{ <*> }{}}}" `shouldParseTo`
      [Product [Raw " ", Field [] [Raw "<$>"] [Raw "v .: "] " <*> " ""]]
  it "should parse Field and ParamN inside Product" $ do
    "{Product {Uncons1} {Uncons2} -> {Cons} {Field {{Param1} <> {Param2}}{ }}}" `shouldParseTo`
      [Product [Uncons 1, Raw " ", Uncons 2, Raw " -> ", Cons, Raw " ",
        Field [] [] [Param 1, Raw " <> ", Param 2] " " ""]]
  it "should parse Field and ParamN inside Sum" $ do
    "{Sum {{Uncons1} {Uncons2} -> {Cons} {Field {{Param1} <> {Param2}} { }}}{\n}}" `shouldParseTo`
      [Sum "" [Uncons 1, Raw " ", Uncons 2, Raw " -> ", Cons, Raw " ",
        Field [] [] [Param 1, Raw " <> ", Param 2] " " ""] "\n" ""]

  it "should parse the FromJSON example" $ do
    parsed <- parseRuleFile "boilerplate/Data/Aeson/FromJSON.rule"
    parsed `shouldBe` (Right fromJSONRule)

  it "should parse the ToJSON example" $ do
    parsed <- parseRuleFile "boilerplate/Data/Aeson/ToJSON.rule"
    parsed `shouldBe` (Right toJSONRule)

fromJSONRule :: Rule
fromJSONRule = Rule [Sugar (Instance "FromJSON"),Raw "\n  parseJSON = withObject \"",Type,Raw "\" $ \\v ->\n",Product [Raw "    ",Cons,Raw " ",Field [] [Raw "<$> "] [Raw "v .: \"",Custom "field" (Just [FieldName]),Raw "\""] " <*> " "",Raw "\n"],Sum "    let withField key parse = (maybe (fail \"\") pure $ H.lookup key v) >>= (withObject (T.unpack key) parse)\n     in " [Raw "(withField \"",Custom "tag" (Just [Cons]),Raw "\" $ ",Field [Raw "\\_ -> pure ",Cons] [Raw "\\v' -> ",Cons,Raw " <$> "] [Raw "v' .: \"",Custom "field" (Just [FieldName]),Raw "\""] " <*> " "",Raw ")"] "\n    <|> " "\n    <|> (fail \"no valid type constructor tags\")\n"]

toJSONRule :: Rule
toJSONRule = Rule [Sugar (Instance "ToJSON"),Raw "\n",Product [Raw "  toJSON ",Uncons 1,Raw " = object ",Field [Raw "[]"] [Raw "["] [Raw "\"",Custom "field" (Just [FieldName]),Raw "\" .= ",Param 1] ", " "]",Raw "\n  toEncoding ",Uncons 1,Raw " = pairs ",Field [Raw "mempty"] [Raw "("] [Raw "\"",Custom "field" (Just [FieldName]),Raw "\" .= ",Param 1] " <> " ")",Raw "\n"],Sum "" [Raw "  toJSON ",Uncons 1,Raw " = object [\"",Custom "tag" (Just [Cons]),Raw "\" .= object ",Field [Raw "[]"] [Raw "["] [Raw "\"",Custom "field" (Just [FieldName]),Raw "\" .= ",Param 1] ", " "]",Raw "]\n"] "" "",Sum "" [Raw "  toEncoding ",Uncons 1,Raw " = pairs . pair \"",Custom "tag" (Just [Cons]),Raw "\" $ ",Field [Raw "emptyObject_"] [Raw "pairs ("] [Raw "\"",Custom "field" (Just [FieldName]),Raw "\" .= ",Param 1] " <> " " :: Series)",Raw "\n"] "" "",Raw "\n"]