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 GhcPlugins 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] -> Constructor -> Hsc Constructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure Constructor
x
    [Constructor]
_ -> SrcSpan -> MsgDoc -> Hsc Constructor
forall a. SrcSpan -> MsgDoc -> Hsc a
Hsc.throwError SrcSpan
srcSpan (MsgDoc -> Hsc Constructor) -> MsgDoc -> Hsc Constructor
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
Ghc.text String
"requires exactly one constructor"
  [(Field, Located RdrName)]
fields <-
    (Field -> Hsc (Field, Located RdrName))
-> [Field] -> Hsc [(Field, Located RdrName)]
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)
    ([Field] -> Hsc [(Field, Located RdrName)])
-> ([Constructor] -> [Field])
-> [Constructor]
-> Hsc [(Field, Located RdrName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field -> OccName) -> [Field] -> [Field]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Field -> OccName
Field.name
    ([Field] -> [Field])
-> ([Constructor] -> [Field]) -> [Constructor] -> [Field]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constructor -> [Field]) -> [Constructor] -> [Field]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Constructor -> [Field]
Constructor.fields
    ([Constructor] -> Hsc [(Field, Located RdrName)])
-> [Constructor] -> Hsc [(Field, Located RdrName)]
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 :: [LStmt GhcPs (LHsExpr GhcPs)]
bindStmts = ((Field, Located RdrName) -> LStmt GhcPs (LHsExpr GhcPs))
-> [(Field, Located RdrName)] -> [LStmt GhcPs (LHsExpr GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\(Field
_, Located RdrName
var) ->
        SrcSpan
-> LPat GhcPs -> LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs)
Hs.bindStmt SrcSpan
srcSpan (SrcSpan -> LIdP GhcPs -> LPat GhcPs
Hs.varPat SrcSpan
srcSpan LIdP GhcPs
Located RdrName
var)
          (LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs))
-> (OccName -> LHsExpr GhcPs)
-> OccName
-> LStmt GhcPs (LHsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> ModuleName -> OccName -> LHsExpr GhcPs
Hs.qualVar SrcSpan
srcSpan ModuleName
quickCheck
          (OccName -> LStmt GhcPs (LHsExpr GhcPs))
-> OccName -> LStmt GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"arbitrary"
      )
      [(Field, Located RdrName)]
fields

    lastStmt :: LStmt GhcPs (LHsExpr GhcPs)
lastStmt =
      SrcSpan -> LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs)
Hs.lastStmt SrcSpan
srcSpan
        (LHsExpr GhcPs -> LStmt GhcPs (LHsExpr GhcPs))
-> ([LHsRecField GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs)
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> LStmt GhcPs (LHsExpr GhcPs)
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 (OccName -> LHsExpr GhcPs) -> OccName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ String -> OccName
Ghc.mkVarOcc String
"pure")
        (LHsExpr GhcPs -> LHsExpr GhcPs)
-> ([LHsRecField GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs)
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> LIdP GhcPs -> HsRecordBinds GhcPs -> LHsExpr GhcPs
Hs.recordCon SrcSpan
srcSpan (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
Ghc.L SrcSpan
srcSpan (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ Constructor -> IdP GhcPs
Constructor.name Constructor
constructor)
        (HsRecordBinds GhcPs -> LHsExpr GhcPs)
-> ([LHsRecField GhcPs (LHsExpr GhcPs)] -> HsRecordBinds GhcPs)
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LHsRecField GhcPs (LHsExpr GhcPs)] -> HsRecordBinds GhcPs
Hs.recFields
        ([LHsRecField GhcPs (LHsExpr GhcPs)]
 -> LStmt GhcPs (LHsExpr GhcPs))
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
-> LStmt GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ((Field, Located RdrName) -> LHsRecField GhcPs (LHsExpr GhcPs))
-> [(Field, Located RdrName)]
-> [LHsRecField GhcPs (LHsExpr GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\(Field
field, Located RdrName
var) ->
              SrcSpan
-> LFieldOcc GhcPs
-> LHsExpr GhcPs
-> LHsRecField GhcPs (LHsExpr GhcPs)
Hs.recField
                  SrcSpan
srcSpan
                  (SrcSpan -> LIdP GhcPs -> LFieldOcc GhcPs
Hs.fieldOcc SrcSpan
srcSpan (Located RdrName -> LFieldOcc GhcPs)
-> (OccName -> Located RdrName) -> OccName -> LFieldOcc GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> OccName -> LIdP GhcPs
Hs.unqual SrcSpan
srcSpan (OccName -> LFieldOcc GhcPs) -> OccName -> LFieldOcc GhcPs
forall a b. (a -> b) -> a -> b
$ Field -> OccName
Field.name Field
field)
                (LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs))
-> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> LIdP GhcPs -> LHsExpr GhcPs
Hs.var SrcSpan
srcSpan LIdP GhcPs
Located RdrName
var
            )
            [(Field, Located RdrName)]
fields

    lHsBind :: LHsBind GhcPs
lHsBind =
      SrcSpan
-> OccName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
Common.makeLHsBind SrcSpan
srcSpan (String -> OccName
Ghc.mkVarOcc String
"arbitrary") []
        (LHsExpr GhcPs -> LHsBind GhcPs)
-> ([LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs)
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
Hs.doExpr SrcSpan
srcSpan
        ([LStmt GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs)
-> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$ [LStmt GhcPs (LHsExpr GhcPs)]
bindStmts
        [LStmt GhcPs (LHsExpr GhcPs)]
-> [LStmt GhcPs (LHsExpr GhcPs)] -> [LStmt GhcPs (LHsExpr GhcPs)]
forall a. Semigroup a => a -> a -> a
<> [LStmt GhcPs (LHsExpr 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")
      [LHsBind GhcPs
lHsBind]

  ([LImportDecl GhcPs], [LHsDecl GhcPs])
-> Hsc ([LImportDecl GhcPs], [LHsDecl GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LImportDecl GhcPs]
lImportDecls, [LHsDecl 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
  Located RdrName
var <-
    SrcSpan -> String -> Hsc (LIdP GhcPs)
Common.makeRandomVariable SrcSpan
srcSpan
    (String -> Hsc (Located RdrName))
-> (OccName -> String) -> OccName -> Hsc (Located RdrName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_")
    (String -> String) -> (OccName -> String) -> OccName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
Ghc.occNameString
    (OccName -> Hsc (Located RdrName))
-> OccName -> Hsc (Located RdrName)
forall a b. (a -> b) -> a -> b
$ Field -> OccName
Field.name Field
field
  (Field, Located RdrName) -> Hsc (Field, Located RdrName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field
field, Located RdrName
var)