module Evoke.Generator.Arbitrary
  ( generate,
  )
where

import qualified Data.List as List
import qualified Evoke.Constant.Module as Module
import qualified Evoke.Generator.Common as Common
import qualified Evoke.Hs as Hs
import qualified Evoke.Hsc as Hsc
import qualified Evoke.Type.Constructor as Constructor
import qualified Evoke.Type.Field as Field
import qualified Evoke.Type.Type as Type
import qualified GHC.Hs as Ghc
import qualified GHC.Plugins as Ghc

generate :: Common.Generator
generate :: Generator
generate ModuleName
_ LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls [String]
_ SrcSpan
srcSpan = do
  Type
type_ <- LIdP GhcPs
-> LHsQTyVars GhcPs -> [LConDecl GhcPs] -> SrcSpan -> Hsc Type
Type.make LIdP GhcPs
lIdP LHsQTyVars GhcPs
lHsQTyVars [LConDecl GhcPs]
lConDecls SrcSpan
srcSpan
  Constructor
constructor <- case Type -> [Constructor]
Type.constructors Type
type_ of
    [Constructor
x] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Constructor
x
    [Constructor]
_ -> forall a. SrcSpan -> SDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ String -> SDoc
Ghc.text String
"requires exactly one constructor"
  [(Field, GenLocated SrcSpanAnnN RdrName)]
fields <-
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SrcSpan -> Field -> Hsc (Field, LIdP GhcPs)
fromField SrcSpan
srcSpan)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Field -> OccName
Field.name
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constructor -> [Field]
Constructor.fields
      forall a b. (a -> b) -> a -> b
$ Type -> [Constructor]
Type.constructors Type
type_

  ModuleName
applicative <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.controlApplicative
  ModuleName
quickCheck <- ModuleName -> Hsc ModuleName
Common.makeRandomModule ModuleName
Module.testQuickCheck
  let lImportDecls :: [LImportDecl GhcPs]
lImportDecls =
        SrcSpan -> [(ModuleName, ModuleName)] -> [LImportDecl GhcPs]
Hs.importDecls
          SrcSpan
srcSpan
          [ (ModuleName
Module.controlApplicative, ModuleName
applicative),
            (ModuleName
Module.testQuickCheck, ModuleName
quickCheck)
          ]

      bindStmts :: [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindStmts =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ( \(Field
_, GenLocated SrcSpanAnnN RdrName
var) ->
              SrcSpan
-> LPat GhcPs -> LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs)
Hs.bindStmt SrcSpan
srcSpan (SrcSpan -> LIdP GhcPs -> LPat GhcPs
Hs.varPat SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
var)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
quickCheck
                forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"arbitrary"
          )
          [(Field, GenLocated SrcSpanAnnN RdrName)]
fields

      lastStmt :: GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
lastStmt =
        SrcSpan -> LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs)
Hs.lastStmt SrcSpan
srcSpan
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
Hs.app SrcSpan
srcSpan (SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
applicative forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"pure")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LIdP GhcPs -> HsRecordBinds GhcPs -> LHsExpr GhcPs
Hs.recordCon SrcSpan
srcSpan (forall e ann. Located e -> LocatedAn ann e
Ghc.reLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ Constructor -> IdP GhcPs
Constructor.name Constructor
constructor)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsRecordBinds GhcPs
Hs.recFields
          forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( \(Field
field, GenLocated SrcSpanAnnN RdrName
var) ->
                SrcSpan
-> LFieldOcc GhcPs
-> LHsExpr GhcPs
-> LHsRecField GhcPs (LHsExpr GhcPs)
Hs.recField
                  SrcSpan
srcSpan
                  (SrcSpan -> LIdP GhcPs -> LFieldOcc GhcPs
Hs.fieldOcc SrcSpan
srcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> OccName -> LIdP GhcPs
Hs.unqual SrcSpan
srcSpan forall a b. (a -> b) -> a -> b
$ Field -> OccName
Field.name Field
field)
                  forall a b. (a -> b) -> a -> b
$ SrcSpan -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan GenLocated SrcSpanAnnN RdrName
var
            )
            [(Field, GenLocated SrcSpanAnnN RdrName)]
fields

      lHsBind :: GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
lHsBind =
        SrcSpan
-> OccName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
Common.makeLHsBind SrcSpan
srcSpan (String -> OccName
Ghc.mkVarOcc String
"arbitrary") []
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
Hs.doExpr SrcSpan
srcSpan
          forall a b. (a -> b) -> a -> b
$ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
bindStmts
            forall a. Semigroup a => a -> a -> a
<> [GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
lastStmt]

      lHsDecl :: LHsDecl GhcPs
lHsDecl =
        SrcSpan
-> Type
-> ModuleName
-> OccName
-> [LHsBind GhcPs]
-> LHsDecl GhcPs
Common.makeInstanceDeclaration
          SrcSpan
srcSpan
          Type
type_
          ModuleName
quickCheck
          (String -> OccName
Ghc.mkClsOcc String
"Arbitrary")
          [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
lHsBind]

  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
lImportDecls, [GenLocated SrcSpanAnnA (HsDecl GhcPs)
lHsDecl])

fromField ::
  Ghc.SrcSpan -> Field.Field -> Ghc.Hsc (Field.Field, Ghc.LIdP Ghc.GhcPs)
fromField :: SrcSpan -> Field -> Hsc (Field, LIdP GhcPs)
fromField SrcSpan
srcSpan Field
field = do
  GenLocated SrcSpanAnnN RdrName
var <-
    SrcSpan -> String -> Hsc (LIdP GhcPs)
Common.makeRandomVariable SrcSpan
srcSpan
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> String
"_")
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
Ghc.occNameString
      forall a b. (a -> b) -> a -> b
$ Field -> OccName
Field.name Field
field
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field
field, GenLocated SrcSpanAnnN RdrName
var)