{-# LANGUAGE OverloadedStrings #-}

module Test.Codec.CBOR.Cuddle.CDDL.Parser where

import Codec.CBOR.Cuddle.CDDL
import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..))
import Codec.CBOR.Cuddle.Parser
import Codec.CBOR.Cuddle.Parser.Lexer (Parser)
import Codec.CBOR.Cuddle.Pretty (PrettyStage)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text qualified as T
import Data.TreeDiff (ToExpr (..), ansiWlBgEditExprCompact, exprDiff)
import Prettyprinter (Pretty, defaultLayoutOptions, layoutPretty, pretty)
import Prettyprinter.Render.String (renderString)
import Prettyprinter.Render.Text (renderStrict)
import Test.Codec.CBOR.Cuddle.CDDL.Gen qualified as Gen ()
import Test.Hspec
import Test.Hspec.Megaparsec
import Test.QuickCheck
import Text.Megaparsec (MonadParsec (..), errorBundlePretty, parse)

parserSpec :: Spec
parserSpec = do
  valueSpec
  occurSpec
  nameSpec
  type1Spec
  type2Spec
  grpEntrySpec
  grpChoiceSpec
  genericSpec
  roundtripSpec
  qcFoundSpec

roundtripSpec :: Spec
roundtripSpec = describe "Roundtripping should be id" $ do
  it "Trip Name" $ trip pName
  xit "Trip Value" $ trip pValue
  xit "Trip Type0" $ tripIndexed pType0
  xit "Trip GroupEntry" $ tripIndexed pGrpEntry
  xit "Trip Rule" $ tripIndexed pRule
  where
    -- We show that, for a printed CDDL document p, print (parse p) == p. Note
    -- that we do not show that parse (print p) is p for a given generated
    -- 'CDDL' doc, since CDDL contains some statements that allow multiple
    -- parsings.
    trip :: forall a. (Eq a, ToExpr a, Show a, Pretty a, Arbitrary a) => Parser a -> Property
    trip pa = property $ \(x :: a) -> within 1000000 $ do
      let printed = printText x
      case parse (pa <* eof) "" printed of
        Left e ->
          counterexample (show printed) $
            counterexample (errorBundlePretty e) $
              property False
        Right parsed ->
          counterexample
            ( renderString . layoutPretty defaultLayoutOptions . ansiWlBgEditExprCompact $
                toExpr x `exprDiff` toExpr parsed
            )
            $ printed `shouldBe` printText parsed
    tripIndexed ::
      forall a.
      ( IndexMappable a ParserStage PrettyStage
      , Eq (a PrettyStage)
      , ToExpr (a PrettyStage)
      , Show (a PrettyStage)
      , Pretty (a PrettyStage)
      , Arbitrary (a PrettyStage)
      ) =>
      Parser (a ParserStage) -> Property
    tripIndexed = trip . fmap (mapIndex @a @ParserStage @PrettyStage)
    printText :: Pretty a => a -> T.Text
    printText = renderStrict . layoutPretty defaultLayoutOptions . pretty

valueSpec :: Spec
valueSpec = describe "pValue" $ do
  it "Parses integer" $
    parse pValue "" "123" `shouldParse` value (VUInt 123)
  it "Parses negative integer" $
    parse pValue "" "-123" `shouldParse` value (VNInt 123)
  it "Parses float" $
    parse pValue "" "3.1415" `shouldParse` value (VFloat64 3.1415)
  it "Parses text" $
    parse pValue "" "\"Hello World\"" `shouldParse` value (VText "Hello World")
  it "Parses boolean" $ do
    parse pValue "" "true" `shouldParse` value (VBool True)
    parse pValue "" "false" `shouldParse` value (VBool False)

occurSpec :: Spec
occurSpec = describe "pOccur" $ do
  it "Parses OneOrMore" $
    parse pOccur "" "+" `shouldParse` OIOneOrMore
  it "Parses ZeroOrMore" $
    parse pOccur "" "*" `shouldParse` OIZeroOrMore
  it "Parses Optional" $
    parse pOccur "" "?" `shouldParse` OIOptional
  it "Parses Lower Bounded" $
    parse pOccur "" "3*" `shouldParse` OIBounded (Just 3) Nothing
  it "Parses Upper Bounded" $
    parse pOccur "" "*9" `shouldParse` OIBounded Nothing (Just 9)
  it "Parses bounded on both sides" $
    parse pOccur "" "3*9" `shouldParse` OIBounded (Just 3) (Just 9)

-- it "result of parsing satisfies what it should" $
--   parse myParser "" "aaaa" `parseSatisfies` ((== 4) . length)

nameSpec :: SpecWith ()
nameSpec = describe "pName" $ do
  it "Parses a boring name" $
    parse pName "" "coin" `shouldParse` Name "coin"
  it "Allows . in the middle" $
    parse pName "" "coin.me" `shouldParse` Name "coin.me"
  it "Allows $ as the last character" $
    parse pName "" "coin.me$" `shouldParse` Name "coin.me$"
  it "Doesn't allow . as a last character" $
    parse pName "" "coin." `shouldFailWith` err 5 ueof

genericSpec :: Spec
genericSpec = describe "generics" $ do
  it "Parses a simple value generic" $
    parse pRule "" "a = b<0>"
      `shouldParse` Rule
        (Name "a")
        Nothing
        AssignEq
        ( TOGType
            ( Type0
                ( Type1
                    ( T2Name
                        (Name "b")
                        ( Just
                            ( GenericArg
                                ( Type1
                                    (T2Value (value $ VUInt 0))
                                    Nothing
                                    mempty
                                    :| []
                                )
                            )
                        )
                    )
                    Nothing
                    mempty
                    :| []
                )
            )
        )
        mempty
  it "Parses a range as a generic" $
    parse pRule "" "a = b<0 ... 1>"
      `shouldParse` Rule
        (Name "a")
        Nothing
        AssignEq
        ( TOGType
            ( Type0
                ( Type1
                    ( T2Name
                        (Name "b")
                        ( Just
                            ( GenericArg
                                ( Type1
                                    (T2Value (value $ VUInt 0))
                                    (Just (RangeOp ClOpen, T2Value (value $ VUInt 1)))
                                    mempty
                                    :| []
                                )
                            )
                        )
                    )
                    Nothing
                    mempty
                    :| []
                )
            )
        )
        mempty

type2Spec :: SpecWith ()
type2Spec = describe "type2" $ do
  describe "Value" $ do
    it "Parses a value" $ do
      parse pType2 "" "123" `shouldParse` T2Value (value $ VUInt 123)
      parse pType2 "" "true" `shouldParse` T2Value (value $ VBool True)
      parse pType2 "" "false" `shouldParse` T2Value (value $ VBool False)
      parse pType2 "" "h'0042ff'"
        `shouldParse` T2Value (value $ VBytes "\x00\x42\xff")
  describe "Map" $ do
    it "Parses a basic group" $
      parse pType2 "" "{ int => string }"
        `shouldParse` T2Map
          ( Group
              { unGroup =
                  GrpChoice
                    { gcGroupEntries =
                        [ GroupEntry
                            { geOccurrenceIndicator = Nothing
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  ( Just
                                      ( MKType
                                          ( Type1
                                              { t1Main = T2Name "int" Nothing
                                              , t1TyOp = Nothing
                                              , t1Comment = mempty
                                              }
                                          )
                                      )
                                  )
                                  ( Type0
                                      { t0Type1 =
                                          Type1
                                            { t1Main = T2Name "string" Nothing
                                            , t1TyOp = Nothing
                                            , t1Comment = mempty
                                            }
                                            :| []
                                      }
                                  )
                            }
                        ]
                    , gcComment = mempty
                    }
                    :| []
              }
          )
    it "Parses a table" $
      parse pType2 "" "{ * int => string }"
        `shouldParse` T2Map
          ( Group
              { unGroup =
                  GrpChoice
                    { gcGroupEntries =
                        [ GroupEntry
                            { geOccurrenceIndicator = Just OIZeroOrMore
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  ( Just
                                      ( MKType
                                          ( Type1
                                              { t1Main = T2Name "int" Nothing
                                              , t1TyOp = Nothing
                                              , t1Comment = mempty
                                              }
                                          )
                                      )
                                  )
                                  ( Type0
                                      { t0Type1 =
                                          Type1
                                            { t1Main = T2Name "string" Nothing
                                            , t1TyOp = Nothing
                                            , t1Comment = mempty
                                            }
                                            :| []
                                      }
                                  )
                            }
                        ]
                    , gcComment = mempty
                    }
                    :| []
              }
          )
    it "Commas are optional" $
      parse pType2 "" "{ 1 => string, 2 => int 3 => bytes}"
        `shouldParse` T2Map
          ( Group
              { unGroup =
                  GrpChoice
                    { gcGroupEntries =
                        [ GroupEntry
                            { geOccurrenceIndicator = Nothing
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  ( Just
                                      (MKType (Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = mempty}))
                                  )
                                  ( Type0
                                      { t0Type1 =
                                          Type1
                                            { t1Main = T2Name "string" Nothing
                                            , t1TyOp = Nothing
                                            , t1Comment = mempty
                                            }
                                            :| []
                                      }
                                  )
                            }
                        , GroupEntry
                            { geOccurrenceIndicator = Nothing
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  ( Just
                                      (MKType (Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = mempty}))
                                  )
                                  ( Type0
                                      { t0Type1 =
                                          Type1
                                            { t1Main = T2Name "int" Nothing
                                            , t1TyOp = Nothing
                                            , t1Comment = mempty
                                            }
                                            :| []
                                      }
                                  )
                            }
                        , GroupEntry
                            { geOccurrenceIndicator = Nothing
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  ( Just
                                      (MKType (Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = mempty}))
                                  )
                                  ( Type0
                                      { t0Type1 =
                                          Type1
                                            { t1Main = T2Name "bytes" Nothing
                                            , t1TyOp = Nothing
                                            , t1Comment = mempty
                                            }
                                            :| []
                                      }
                                  )
                            }
                        ]
                    , gcComment = mempty
                    }
                    :| []
              }
          )
  describe "Array" $ do
    it "Parses an array with an alternative" $
      parse pType2 "" "[int // string]"
        `shouldParse` T2Array
          ( Group
              { unGroup =
                  GrpChoice
                    { gcGroupEntries =
                        [ GroupEntry
                            { geOccurrenceIndicator = Nothing
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  Nothing
                                  ( Type0
                                      { t0Type1 =
                                          Type1
                                            { t1Main = T2Name "int" Nothing
                                            , t1TyOp = Nothing
                                            , t1Comment = mempty
                                            }
                                            :| []
                                      }
                                  )
                            }
                        ]
                    , gcComment = mempty
                    }
                    :| [ GrpChoice
                           { gcGroupEntries =
                               [ GroupEntry
                                   { geOccurrenceIndicator = Nothing
                                   , geExt = mempty
                                   , geVariant =
                                       GEType
                                         Nothing
                                         ( Type0
                                             { t0Type1 =
                                                 Type1
                                                   { t1Main = T2Name "string" Nothing
                                                   , t1TyOp = Nothing
                                                   , t1Comment = mempty
                                                   }
                                                   :| []
                                             }
                                         )
                                   }
                               ]
                           , gcComment = mempty
                           }
                       ]
              }
          )

    it "Parses an array with a value alternative" $
      parse pType2 "" "[0 // 1]"
        `shouldParse` T2Array
          ( Group
              { unGroup =
                  GrpChoice
                    { gcGroupEntries =
                        [ GroupEntry
                            { geOccurrenceIndicator = Nothing
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  Nothing
                                  ( Type0
                                      { t0Type1 =
                                          Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = mempty} :| []
                                      }
                                  )
                            }
                        ]
                    , gcComment = mempty
                    }
                    :| [ GrpChoice
                           { gcGroupEntries =
                               [ GroupEntry
                                   { geOccurrenceIndicator = Nothing
                                   , geExt = mempty
                                   , geVariant =
                                       GEType
                                         Nothing
                                         ( Type0
                                             { t0Type1 =
                                                 Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = mempty} :| []
                                             }
                                         )
                                   }
                               ]
                           , gcComment = mempty
                           }
                       ]
              }
          )
    it "Trailing commas permitted" $
      parse pType2 "" "[ 1 , ]"
        `shouldParse` T2Array
          ( Group
              { unGroup =
                  GrpChoice
                    { gcGroupEntries =
                        [ GroupEntry
                            { geOccurrenceIndicator = Nothing
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  Nothing
                                  ( Type0
                                      { t0Type1 =
                                          Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = mempty} :| []
                                      }
                                  )
                            }
                        ]
                    , gcComment = mempty
                    }
                    :| []
              }
          )
    it "Values don't need a space" $
      parse pType2 "" "[ 2soon ]"
        `shouldParse` T2Array
          ( Group
              { unGroup =
                  GrpChoice
                    { gcGroupEntries =
                        [ GroupEntry
                            { geOccurrenceIndicator = Nothing
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  Nothing
                                  ( Type0
                                      { t0Type1 =
                                          Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = mempty} :| []
                                      }
                                  )
                            }
                        , GroupEntry
                            { geOccurrenceIndicator = Nothing
                            , geExt = mempty
                            , geVariant =
                                GEType
                                  Nothing
                                  ( Type0
                                      { t0Type1 =
                                          Type1
                                            { t1Main = T2Name "soon" Nothing
                                            , t1TyOp = Nothing
                                            , t1Comment = mempty
                                            }
                                            :| []
                                      }
                                  )
                            }
                        ]
                    , gcComment = mempty
                    }
                    :| []
              }
          )

grpEntrySpec :: SpecWith ()
grpEntrySpec = describe "GroupEntry" $ do
  it "Prefers GEType over GERef for names" $
    parse pGrpEntry "" "int"
      `shouldParse` GroupEntry
        { geOccurrenceIndicator = Nothing
        , geExt = mempty
        , geVariant =
            GEType
              Nothing
              ( Type0
                  { t0Type1 =
                      Type1
                        { t1Main = T2Name "int" Nothing
                        , t1TyOp = Nothing
                        , t1Comment = mempty
                        }
                        :| []
                  }
              )
        }
  it "Should parse part of a group alternative" $
    parse pGrpEntry "" "int // notConsideredHere"
      `shouldParse` GroupEntry
        { geOccurrenceIndicator = Nothing
        , geExt = mempty
        , geVariant =
            GEType
              Nothing
              ( Type0
                  { t0Type1 =
                      Type1
                        { t1Main = T2Name "int" Nothing
                        , t1TyOp = Nothing
                        , t1Comment = mempty
                        }
                        :| []
                  }
              )
        }
  it "Should parse a generic" $
    parse pGrpEntry "" "a<0 ... #6(0)>"
      `shouldParse` GroupEntry
        { geOccurrenceIndicator = Nothing
        , geExt = mempty
        , geVariant =
            GEType
              Nothing
              ( Type0
                  { t0Type1 =
                      Type1
                        { t1Main =
                            T2Name
                              "a"
                              ( Just
                                  ( GenericArg
                                      ( Type1
                                          { t1Main = T2Value (value $ VUInt 0)
                                          , t1TyOp =
                                              Just
                                                ( RangeOp ClOpen
                                                , T2Tag
                                                    Nothing
                                                    ( Type0
                                                        { t0Type1 =
                                                            Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = mempty} :| []
                                                        }
                                                    )
                                                )
                                          , t1Comment = mempty
                                          }
                                          :| []
                                      )
                                  )
                              )
                        , t1TyOp = Nothing
                        , t1Comment = mempty
                        }
                        :| []
                  }
              )
        }
  it "Parses a GEType with an Occurrence Indicator" $
    parse pGrpEntry "" "0* a"
      `shouldParse` GroupEntry
        (Just (OIBounded (Just 0) Nothing))
        ( GEType
            Nothing
            (Type0 (Type1 (T2Name (Name "a") Nothing) Nothing mempty :| []))
        )
        mempty

grpChoiceSpec :: SpecWith ()
grpChoiceSpec = describe "GroupChoice" $ do
  it "Should parse part of a group alternative" $
    parse pGrpChoice "" "int // string"
      `shouldParse` GrpChoice
        [ GroupEntry
            Nothing
            ( GEType
                Nothing
                ( Type0
                    ( Type1
                        (T2Name (Name "int") Nothing)
                        Nothing
                        mempty
                        :| []
                    )
                )
            )
            mempty
        ]
        mempty

type1Spec :: Spec
type1Spec = describe "Type1" $ do
  describe "CtlOp" $ do
    it "Should parse a basic control operator" $
      parse pType1 "" "uint .size 3"
        `shouldParse` Type1
          (T2Name (Name "uint") Nothing)
          (Just (CtrlOp CtlOp.Size, T2Value (value $ VUInt 3)))
          mempty
  describe "RangeOp" $ do
    it "Should parse a closed range operator" $
      parse pType1 "" "0 .. 3"
        `shouldParse` Type1
          (T2Value (value $ VUInt 0))
          (Just (RangeOp Closed, T2Value (value $ VUInt 3)))
          mempty
    it "Should parse a clopen range operator" $
      parse pType1 "" "0 ... 3"
        `shouldParse` Type1
          (T2Value (value $ VUInt 0))
          (Just (RangeOp ClOpen, T2Value (value $ VUInt 3)))
          mempty

parseExample :: (Show a, Eq a) => T.Text -> Parser a -> a -> Spec
parseExample str parser val =
  it (T.unpack str) $
    parse (parser <* eof) "" str `shouldParse` val

-- | A bunch of cases found by hedgehog/QC
qcFoundSpec :: Spec
qcFoundSpec =
  describe "Generated test cases" $ do
    parseExample "{} .ge & i<{}, 3>" pType1 $
      Type1
        { t1Main =
            T2Map
              (Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = mempty} :| []})
        , t1TyOp =
            Just
              ( CtrlOp CtlOp.Ge
              , T2EnumRef
                  "i"
                  ( Just
                      ( GenericArg
                          ( Type1
                              { t1Main =
                                  T2Map
                                    (Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = mempty} :| []})
                              , t1TyOp = Nothing
                              , t1Comment = mempty
                              }
                              :| [Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = mempty}]
                          )
                      )
                  )
              )
        , t1Comment = mempty
        }
    parseExample "S = 0* ()" pRule $
      Rule
        (Name "S")
        Nothing
        AssignEq
        ( TOGGroup
            ( GroupEntry
                (Just (OIBounded (Just 0) Nothing))
                (GEGroup (Group (GrpChoice mempty mempty :| [])))
                mempty
            )
        )
        mempty
    parseExample
      "W = \"6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95\" : \"u\""
      pRule
      ( Rule
          (Name "W")
          Nothing
          AssignEq
          ( TOGGroup
              ( GroupEntry
                  Nothing
                  ( GEType
                      (Just (MKValue (value $ VText "6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95")))
                      (Type0 (Type1 (T2Value (value $ VText "u")) Nothing mempty :| []))
                  )
                  mempty
              )
          )
          mempty
      )