{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
module Ampersand.Test.Parser.ArbitraryTree () where

import Test.QuickCheck
import Data.Char
import Data.List (nub,isInfixOf)
import Ampersand.Core.ParseTree
import Ampersand.Input.ADL1.Lexer (keywords)
import Ampersand.Basics
import qualified Data.List.NonEmpty as NEL

-- Useful functions to build on the quick check functions

-- Generates a simple ascii character
printable :: Gen Char
printable = suchThat arbitrary isValid
    where isValid x = isPrint x && x <= 'Ñ' -- printable ASCII characters

-- Generates a simple string of ascii characters
safeStr :: Gen String
safeStr = listOf printable `suchThat` noEsc

-- Generates a simple non-empty string of ascii characters
safeStr1 :: Gen String
safeStr1 = listOf1 printable `suchThat` noEsc

noEsc :: String -> Bool
noEsc = notElem '\\'

-- Genrates a valid ADL identifier
identifier :: Gen String
identifier = suchThat str2 noKeyword
    where noKeyword x = x `notElem` keywords
          -- The prelude functions accept Unicode characters
          idChar = elements (['a'..'z']++['A'..'Z']++['0'..'9']++"_")
          str2   = suchThat (listOf1 idChar) (\s -> length s > 1)

-- Genrates a valid ADL upper-case identifier
upperId :: Gen String
upperId = suchThat identifier startUpper
    where startUpper = isUpper . head

-- Genrates a valid ADL lower-case identifier
lowerId :: Gen String
lowerId = suchThat identifier startLower
    where startLower = isLower . head

-- Generates an object
objTermPrim :: Bool -> Int -> Gen (P_BoxItem TermPrim)
objTermPrim isTxtAllowed 0 = objTermPrim isTxtAllowed 1 -- minimum of 1 sub interface
objTermPrim isTxtAllowed i =
  makeObj isTxtAllowed genPrim ifc genView i
    where ifc :: Int -> Gen (P_SubIfc TermPrim)
          ifc n = subIfc (objTermPrim True) (n`div`2)
          --TODO: The view is never tested like this
          genView = return Nothing
          genPrim :: Gen TermPrim
          genPrim = PNamedR <$> relationRef

--TODO: refactor obj/ifc generators
genObj :: Arbitrary a => Bool -> Int -> Gen (P_BoxItem a)
genObj isTxtAllowed = makeObj isTxtAllowed arbitrary genIfc (return Nothing)

makeObj :: Bool -> Gen a -> (Int -> Gen (P_SubIfc a)) -> Gen (Maybe String) -> Int -> Gen (P_BoxItem a)
makeObj isTxtAllowed genPrim ifcGen genView n =
  oneof $ [P_BxExpr <$> lowerId  <*> arbitrary <*> term <*> arbitrary <*> genView <*> ifc]
        ++[P_BxTxt  <$> lowerId  <*> arbitrary <*> safeStr | isTxtAllowed]
     where term = Prim <$> genPrim
           ifc  = if n == 0 then return Nothing
                  else Just <$> ifcGen (n`div`2)
        
genIfc :: Arbitrary a => Int -> Gen (P_SubIfc a)
genIfc = subIfc $ genObj True

subIfc :: (Int -> Gen (P_BoxItem a)) -> Int -> Gen (P_SubIfc a)
subIfc objGen n =
    if n == 0 then P_InterfaceRef <$> arbitrary <*> arbitrary <*> safeStr1
    else P_Box          <$> arbitrary <*> boxKey   <*> vectorOf n (objGen$ n`div`2)
    where boxKey = elements [Nothing, Just "ROWS", Just "COLS", Just "TABS"]


--- Now the arbitrary instances
instance Arbitrary P_Cruds where
    arbitrary = P_Cruds <$> arbitrary
                        <*> suchThat (sublistOf "cCrRuUdD") isCrud
      where isCrud str = nub (map toUpper str) == map toUpper str

instance Arbitrary Origin where
    arbitrary = return OriginUnknown

instance Arbitrary P_Context where
    arbitrary = PCtx
       <$> upperId   -- name
       <*> listOf arbitrary  -- pos
       <*> arbitrary  -- lang
       <*> arbitrary  -- markup
       <*> listOf arbitrary -- patterns
       <*> listOf arbitrary -- rules
       <*> listOf arbitrary -- relations
       <*> listOf arbitrary -- concepts
       <*> listOf arbitrary -- identities
       <*> listOf arbitrary -- role rules
       <*> listOf arbitrary -- role relations
       <*> listOf arbitrary -- representation
       <*> listOf arbitrary -- views
       <*> listOf arbitrary -- gen definitions
       <*> listOf arbitrary -- interfaces
       <*> listOf arbitrary -- purposes
       <*> listOf arbitrary -- populations
       <*> listOf arbitrary -- generic meta information

instance Arbitrary Meta where
    arbitrary = Meta <$> arbitrary <*> arbitrary <*>  safeStr  <*> safeStr

instance Arbitrary MetaObj where
    arbitrary = return ContextMeta

instance Arbitrary P_RoleRelation where
    arbitrary = P_RR <$> arbitrary <*> listOf1 arbitrary <*> listOf1 relationRef

instance Arbitrary P_RoleRule where
    arbitrary = Maintain <$> arbitrary <*> listOf1 arbitrary <*> listOf1 safeStr

instance Arbitrary Representation where
    arbitrary = Repr <$> arbitrary <*> listOf1 upperId <*> arbitrary

instance Arbitrary TType where
    arbitrary = elements [ tt | tt <- [minBound..] , tt /= TypeOfOne]

instance Arbitrary Role where
    arbitrary =
      oneof [ Role    <$> safeStr
            , Service <$> safeStr
            ]

instance Arbitrary P_Pattern where
    arbitrary = P_Pat <$> arbitrary <*> safeStr1  <*> arbitrary <*> arbitrary <*> arbitrary
                      <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
                      <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary

instance Arbitrary P_Relation where
    arbitrary = P_Sgn <$> lowerId         -- name
                      <*> arbitrary       -- sign
                      <*> arbitrary       -- props
                      <*> listOf safeStr1 -- pragma. Should be three, but the grammar allows more.
                      <*> arbitrary       -- meaning
                      <*> arbitrary       -- pairs
                      <*> arbitrary       -- origin

instance Arbitrary a => Arbitrary (Term a) where
    arbitrary = do lv <- choose (0,6)
                   sized (genTerm lv)

genTerm :: Arbitrary a => Int -> Int -> Gen (Term a)
genTerm lv n = if n == 0
               then Prim <$> arbitrary
               else oneof options
    where gen :: Arbitrary a => Int -> Gen (Term a)
          gen l = genTerm l (n`div`2)

          options :: Arbitrary a => [Gen (Term a)]
          options = concat $ drop lv levels

          levels :: Arbitrary a => [[Gen (Term a)]]
          levels = [
            -- level 0: pRule
            [PEqu <$> arbitrary <*> gen 1 <*> gen 1,
             PInc <$> arbitrary <*> gen 1 <*> gen 1],
            -- level 1: pTerm
            [PIsc <$> arbitrary <*> gen 2 <*> gen 2,
             PUni <$> arbitrary <*> gen 2 <*> gen 2],
            -- level 2: pTrm2
            [PDif <$> arbitrary <*> gen 3 <*> gen 3],
            -- level 3: pTrm3
            [PLrs <$> arbitrary <*> gen 4 <*> gen 4,
             PRrs <$> arbitrary <*> gen 4 <*> gen 4,
             PDia <$> arbitrary <*> gen 4 <*> gen 4],
            -- level 4: pTrm4
            [PCps <$> arbitrary <*> gen 5 <*> gen 5,
             PRad <$> arbitrary <*> gen 5 <*> gen 5,
             PPrd <$> arbitrary <*> gen 5 <*> gen 5],
            -- level 5: pTrm5
            [PKl0 <$> arbitrary <*> gen 6,
             PKl1 <$> arbitrary <*> gen 6,
             PFlp <$> arbitrary <*> gen 6,
             PCpl <$> arbitrary <*> gen 6],
            -- level 6: pTrm6
            [PBrk <$> arbitrary <*> gen 1,
             Prim <$> arbitrary]]

instance Arbitrary TermPrim where
    arbitrary =
        oneof [
           PI <$> arbitrary,
           Pid <$> arbitrary <*> genConceptOne,
           Patm <$> arbitrary <*> arbitrary <*> maybeConceptOne,
           PVee <$> arbitrary,
           Pfull <$> arbitrary <*> genConceptOne <*> genConceptOne,
           PNamedR <$> relationRef
       ]
      where maybeConceptOne = oneof [return Nothing, Just <$> genConceptOne]

relationRef :: Gen P_NamedRel
relationRef = PNamedRel <$> arbitrary <*> lowerId <*> arbitrary

instance Arbitrary a => Arbitrary (PairView (Term a)) where
    arbitrary = f <$> listOf1 arbitrary
         where f (x:xs) = PairView {ppv_segs = x NEL.:| xs}
               f []     = fatal "This fatal can only occur if listOf1 doesn't do what it is supposed to do."
instance Arbitrary a => Arbitrary (PairViewSegment (Term a)) where
    arbitrary = oneof [
            PairViewText <$> arbitrary <*> safeStr,
            PairViewExp <$> arbitrary <*> arbitrary <*> sized(genTerm 1) -- only accepts pTerm, no pRule.
        ]

instance Arbitrary a => Arbitrary (PairViewTerm a) where
    arbitrary = PairViewTerm <$> arbitrary -- should be only (PairView (Term a))

instance Arbitrary a => Arbitrary (PairViewSegmentTerm a) where
    arbitrary = PairViewSegmentTerm <$> arbitrary -- should be only PairViewSegment (Term a)

instance Arbitrary SrcOrTgt where
    arbitrary = elements [minBound..]

instance Arbitrary a => Arbitrary (P_Rule a) where
    arbitrary = P_Ru <$> arbitrary <*> safeStr <*> ruleTerm  <*> arbitrary <*> arbitrary
                     <*> arbitrary
              where ruleTerm = sized $ genTerm 0 -- rule is a term level 0

instance Arbitrary ConceptDef where
    arbitrary = Cd <$> arbitrary <*> safeStr <*> safeStr
                   <*> safeStr  <*> safeStr

instance Arbitrary PAtomPair where
    arbitrary = PPair <$> arbitrary <*> arbitrary <*> arbitrary

instance Arbitrary P_Population where
    arbitrary =
        oneof [
          P_RelPopu Nothing Nothing <$> arbitrary <*> arbitrary <*> arbitrary,
          P_CptPopu <$> arbitrary <*> lowerId <*> arbitrary
        ]

instance Arbitrary P_NamedRel where
    arbitrary = PNamedRel <$> arbitrary <*> lowerId <*> arbitrary

instance Arbitrary PAtomValue where
  -- Arbitrary must produce valid input from an ADL-file, so no Xlsx stuff allowed here,
  -- otherwise it is likely that Quickcheck will fail because of it.
    arbitrary = oneof
       [ScriptString <$> arbitrary <*> safeStr `suchThat`  stringConstraints,
        ScriptInt <$> arbitrary <*> arbitrary `suchThat` (0 <= ) ,
        ScriptFloat <$> arbitrary <*> arbitrary `suchThat` (0 <= ) ,
--        ScriptDate <$> arbitrary <*> arbitrary,
--        ScriptDateTime <$> arbitrary <*> arbitrary,
        ComnBool <$> arbitrary <*> arbitrary
       ]
     where stringConstraints :: String -> Bool
           stringConstraints str =
             case readLitChar str of
              [(c,cs)] -> notElem c ['\'', '"', '\\'] && stringConstraints cs
              _        -> True  -- end of string
instance Arbitrary P_Interface where
    arbitrary = P_Ifc <$> arbitrary
                      <*> safeStr1
                      <*> listOf arbitrary
                      <*> sized (objTermPrim False) <*> arbitrary <*> safeStr

instance Arbitrary a => Arbitrary (P_SubIfc a) where
    arbitrary = sized genIfc

instance Arbitrary P_IdentDef where
    arbitrary = P_Id <$> arbitrary <*> safeStr <*> arbitrary 
                     <*> listOf1 arbitrary
instance Arbitrary P_IdentSegment where
    arbitrary = P_IdentExp <$> sized (objTermPrim False)

instance Arbitrary a => Arbitrary (P_ViewD a) where
    arbitrary = P_Vd <$> arbitrary <*> safeStr <*> genConceptOne
                    <*> arbitrary <*> arbitrary <*> listOf1 arbitrary

instance Arbitrary ViewHtmlTemplate where
    arbitrary = ViewHtmlTemplateFile <$> safeStr

instance Arbitrary a => Arbitrary (P_ViewSegment a) where
    arbitrary = P_ViewSegment <$> (Just <$> safeStr) <*> arbitrary <*> arbitrary 
instance Arbitrary a => Arbitrary (P_ViewSegmtPayLoad a) where
    arbitrary =
        oneof [ P_ViewExp  <$> sized(genTerm 1) -- only accepts pTerm, no pRule.
              , P_ViewText <$> safeStr
              ]

instance Arbitrary PPurpose where
    arbitrary = PRef2 <$> arbitrary <*> arbitrary <*> arbitrary <*> listOf safeStr1

instance Arbitrary PRef2Obj where
    arbitrary =
        oneof [
            PRef2ConceptDef <$> safeStr,
            PRef2Relation <$> relationRef,
            PRef2Rule <$> upperId,
            PRef2IdentityDef <$> upperId,
            PRef2ViewDef <$> upperId,
            PRef2Pattern <$> upperId,
            PRef2Interface <$> upperId,
            PRef2Context <$> upperId
        ]

instance Arbitrary PMeaning where
    arbitrary = PMeaning <$> arbitrary

instance Arbitrary PMessage where
    arbitrary = PMessage <$> arbitrary

instance Arbitrary P_Concept where
    arbitrary = PCpt <$> upperId

genConceptOne :: Gen P_Concept
genConceptOne = oneof [arbitrary, return P_Singleton]

instance Arbitrary P_Sign where
    arbitrary = P_Sign <$> arbitrary <*> arbitrary

instance Arbitrary PClassify where
    arbitrary =
        fun <$> arbitrary <*> arbitrary <*> listOf1 arbitrary
        where
          fun p s g = PClassify p s (NEL.fromList g)

instance Arbitrary Lang where
    arbitrary = elements [minBound..]

instance Arbitrary P_Markup where
    arbitrary = P_Markup <$> arbitrary <*> arbitrary <*> safeStr `suchThat` noEndMarkup
     where 
       noEndMarkup :: String -> Bool
       noEndMarkup = not . isInfixOf "+}"

instance Arbitrary PandocFormat where
    arbitrary = elements [minBound..]

instance Arbitrary Prop where
    arbitrary = elements [minBound..]
