content: module Axel.Test.ASTGen where
  
  import Axel.Prelude
  
  import qualified Axel.AST as AST
  import qualified Axel.Sourcemap as SM
  
  import Control.Applicative
  import Control.Lens (isn't)
  
  import qualified Hedgehog.Gen as Gen
  import qualified Hedgehog.Range as Range
  
  import TestUtils
  
  genIdentifier :: (MonadGen m) => m AST.Identifier
  genIdentifier = Gen.text (Range.linear 1 5) Gen.alpha
  
  genLiteral :: (MonadGen m) => m (AST.Literal (Maybe SM.Expression))
  genLiteral =
    Gen.choice
      [ AST.LChar Nothing <$> Gen.unicode
      , AST.LFloat Nothing <$> Gen.float (Range.exponentialFloat (-10000) 10000)
      , AST.LInt Nothing <$> Gen.int Range.constantBounded
      , AST.LString Nothing <$> Gen.text (Range.linear 0 5) Gen.unicode
      ]
  
  genCaseBlock :: (MonadGen m) => m (AST.CaseBlock (Maybe SM.Expression))
  genCaseBlock =
    AST.CaseBlock Nothing <$> genExpression <*>
    Gen.list (Range.linear 0 10) ((,) <$> genExpression <*> genExpression)
  
  genFunctionApplication ::
       (MonadGen m) => m (AST.FunctionApplication (Maybe SM.Expression))
  genFunctionApplication =
    AST.FunctionApplication Nothing <$>
    Gen.filter (isn't AST._EEmptySExpression) genExpression <*>
    Gen.list (Range.linear 0 10) genExpression
  
  genLambda :: (MonadGen m) => m (AST.Lambda (Maybe SM.Expression))
  genLambda =
    AST.Lambda Nothing <$> Gen.list (Range.linear 0 10) genExpression <*>
    genExpression
  
  genLetBlock :: (MonadGen m) => m (AST.LetBlock (Maybe SM.Expression))
  genLetBlock =
    AST.LetBlock Nothing <$>
    Gen.list (Range.linear 0 10) ((,) <$> genExpression <*> genExpression) <*>
    genExpression
  
  genPatternBinding ::
       (MonadGen m) => m (AST.PatternBinding (Maybe SM.Expression))
  genPatternBinding =
    AST.PatternBinding Nothing <$> (AST.EIdentifier Nothing <$> genIdentifier) <*>
    genExpression
  
  genRawExpression :: (MonadGen m) => m Text
  genRawExpression = Gen.text (Range.linear 0 10) Gen.unicode
  
  genRecordDefinition ::
       (MonadGen m) => m (AST.RecordDefinition (Maybe SM.Expression))
  genRecordDefinition =
    AST.RecordDefinition Nothing <$>
    Gen.list (Range.linear 0 10) ((,) <$> genIdentifier <*> genExpression)
  
  genRecordType :: (MonadGen m) => m (AST.RecordType (Maybe SM.Expression))
  genRecordType =
    AST.RecordType Nothing <$>
    Gen.list (Range.linear 0 10) ((,) <$> genIdentifier <*> genExpression)
  
  genExpression :: (MonadGen m) => m (AST.Expression (Maybe SM.Expression))
  genExpression =
    Gen.recursive
      Gen.choice
      [ pure $ AST.EEmptySExpression Nothing
      , AST.EIdentifier Nothing <$> genIdentifier
      ]
      [ AST.ECaseBlock <$> genCaseBlock
      , AST.EFunctionApplication <$> genFunctionApplication
      , AST.ELambda <$> genLambda
      , AST.ELetBlock <$> genLetBlock
      , AST.ELiteral <$> genLiteral
      , AST.EPatternBinding <$> genPatternBinding
      , AST.ERawExpression Nothing <$> genRawExpression
      , AST.ERecordDefinition <$> genRecordDefinition
      , AST.ERecordType <$> genRecordType
      ]
  
  genTypeDefinition ::
       (MonadGen m) => m (AST.TypeDefinition (Maybe SM.Expression))
  genTypeDefinition =
    Gen.choice
      [ AST.ProperType Nothing <$> genIdentifier
      , AST.TypeConstructor Nothing <$> genFunctionApplication
      ]
  
  genDataDeclaration ::
       (Alternative m, MonadGen m)
    => m (AST.DataDeclaration (Maybe SM.Expression))
  genDataDeclaration =
    AST.DataDeclaration Nothing <$> genTypeDefinition <*>
    Gen.list (Range.linear 0 10) genExpression <*>
    genConstraints
  
  genFunctionDefinition ::
       (Alternative m, MonadGen m)
    => Maybe Int
    -> m (AST.FunctionDefinition (Maybe SM.Expression))
  genFunctionDefinition numArgs =
    let genArgs =
          case numArgs of
            Just n -> Range.linear n n
            Nothing -> Range.linear 0 10
     in AST.FunctionDefinition Nothing <$> genIdentifier <*>
        Gen.list genArgs genExpression <*>
        genExpression <*>
        Gen.list
          (Range.linear 0 10)
          ((AST.STypeSignature <$> genTypeSignature) <|>
           (AST.SFunctionDefinition <$> genFunctionDefinition Nothing))
  
  genPragma :: (MonadGen m) => m (AST.Pragma (Maybe SM.Expression))
  genPragma = AST.Pragma Nothing <$> Gen.text (Range.linear 0 10) Gen.ascii
  
  genMacroDefinition ::
       (Alternative m, MonadGen m)
    => m (AST.MacroDefinition (Maybe SM.Expression))
  genMacroDefinition =
    AST.MacroDefinition Nothing <$> genFunctionDefinition (Just 1)
  
  genImport :: (MonadGen m) => m (AST.Import (Maybe SM.Expression))
  genImport =
    Gen.choice
      [ AST.ImportItem Nothing <$> genIdentifier
      , AST.ImportType Nothing <$> genIdentifier <*>
        Gen.list (Range.linear 0 10) genIdentifier
      ]
  
  genImportSpecification ::
       (MonadGen m) => Bool -> m (AST.ImportSpecification (Maybe SM.Expression))
  genImportSpecification importAll =
    let options =
          (AST.ImportOnly Nothing <$> Gen.list (Range.linear 0 10) genImport) :
          [pure $ AST.ImportAll Nothing | importAll]
     in Gen.choice options
  
  genQualifiedImport ::
       (MonadGen m) => m (AST.QualifiedImport (Maybe SM.Expression))
  genQualifiedImport =
    AST.QualifiedImport Nothing <$> genIdentifier <*> genIdentifier <*>
    genImportSpecification True
  
  genMacroImport :: (MonadGen m) => m (AST.MacroImport (Maybe SM.Expression))
  genMacroImport =
    AST.MacroImport Nothing <$> genIdentifier <*>
    Gen.list (Range.linear 0 10) genIdentifier
  
  genNewtypeDeclaration ::
       (Alternative m, MonadGen m)
    => m (AST.NewtypeDeclaration (Maybe SM.Expression))
  genNewtypeDeclaration =
    AST.NewtypeDeclaration Nothing <$> genTypeDefinition <*> genExpression <*>
    genConstraints
  
  genRawStatement :: (MonadGen m) => m Text
  genRawStatement = Gen.text (Range.linear 0 10) Gen.unicode
  
  genRestrictedImport ::
       (MonadGen m) => Bool -> m (AST.RestrictedImport (Maybe SM.Expression))
  genRestrictedImport importAll =
    AST.RestrictedImport Nothing <$> genIdentifier <*>
    genImportSpecification importAll
  
  genTopLevel ::
       (Alternative m, MonadGen m) => m (AST.TopLevel (Maybe SM.Expression))
  genTopLevel = AST.TopLevel Nothing <$> Gen.list (Range.linear 0 10) genStatement
  
  genConstraints :: (Alternative m, MonadGen m) => m [AST.SMExpression]
  genConstraints =
    Gen.list
      (Range.linear 0 10)
      ((AST.EIdentifier Nothing <$> genIdentifier) <|>
       (AST.EFunctionApplication <$> genFunctionApplication))
  
  genTypeclassDefinition ::
       (Alternative m, MonadGen m)
    => m (AST.TypeclassDefinition (Maybe SM.Expression))
  genTypeclassDefinition =
    AST.TypeclassDefinition Nothing <$>
    ((AST.EFunctionApplication <$> genFunctionApplication) <|>
     (AST.EIdentifier Nothing <$> genIdentifier)) <*>
    genConstraints <*>
    Gen.list (Range.linear 0 10) genTypeSignature
  
  genTypeclassInstance ::
       (Alternative m, MonadGen m)
    => m (AST.TypeclassInstance (Maybe SM.Expression))
  genTypeclassInstance =
    AST.TypeclassInstance Nothing <$>
    ((AST.EFunctionApplication <$> genFunctionApplication) <|>
     (AST.EIdentifier Nothing <$> genIdentifier)) <*>
    genConstraints <*>
    Gen.list (Range.linear 0 10) (genFunctionDefinition Nothing)
  
  genTypeSignature ::
       (Alternative m, MonadGen m) => m (AST.TypeSignature (Maybe SM.Expression))
  genTypeSignature =
    AST.TypeSignature Nothing <$> genIdentifier <*> genConstraints <*>
    genExpression
  
  genTypeSynonym :: (MonadGen m) => m (AST.TypeSynonym (Maybe SM.Expression))
  genTypeSynonym = AST.TypeSynonym Nothing <$> genExpression <*> genExpression
  
  genStatement :: (Alternative m, MonadGen m) => m AST.SMStatement
  genStatement =
    Gen.recursive
      Gen.choice
      [ AST.SDataDeclaration <$> genDataDeclaration
      , AST.SPragma <$> genPragma
      , AST.SMacroImport <$> genMacroImport
      , AST.SModuleDeclaration Nothing <$> genIdentifier
      , AST.SQualifiedImport <$> genQualifiedImport
      , AST.SRawStatement Nothing <$> genRawStatement
      , AST.SRestrictedImport <$> genRestrictedImport True
      , AST.STypeclassDefinition <$> genTypeclassDefinition
      , AST.STypeclassInstance <$> genTypeclassInstance
      , AST.STypeSignature <$> genTypeSignature
      , AST.STypeSynonym <$> genTypeSynonym
      ]
      [ AST.STopLevel <$> genTopLevel
      , AST.SFunctionDefinition <$> genFunctionDefinition Nothing
      , AST.SMacroDefinition <$> genMacroDefinition
      ]
  