-- This file is part of Goatee.
--
-- Copyright 2014-2021 Bryan Gardiner
--
-- Goatee is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- Goatee is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE CPP, TemplateHaskell #-}
{-# OPTIONS_HADDOCK hide #-}

-- | Core property-related data types, and some Template Haskell declarations
-- for defining property metadata.
--
-- Import "Game.Goatee.Lib.Property" rather than importing this module.
module Game.Goatee.Lib.Property.Base (
  -- * Properties
  Property (..),
  -- * Property metadata
  PropertyType (..),
  Descriptor (..), ValuedDescriptor (..),
  AnyDescriptor (..), AnyValuedDescriptor (..), AnyCoordListDescriptor,
  PropertyInfo,
  ValuedPropertyInfo (ValuedPropertyInfo),
  -- * (Internal) Property metadata declaration
  defProperty, defValuedProperty,
  ) where

import Game.Goatee.Lib.Property.Value (PropertyValueType(..), nonePvt)
import Game.Goatee.Lib.Renderer
import Game.Goatee.Lib.Types
import Language.Haskell.TH (
  Info (DataConI), DecsQ, Name, Type (AppT),
  appE, appT, caseE, conE, conP, conT, lam1E, match, mkName, newName,
  normalB, recP, reify, sigD, stringE, valD, varE, varP, wildP,
  )
import Text.ParserCombinators.Parsec (Parser)

-- | An SGF property that gives a node meaning.  A property is /known/ if its
-- meaning is defined by the SGF specification, and /unknown/ otherwise.  Known
-- properties each have their own data constructors.  Unknown properties are
-- represented by the 'UnknownProperty' data constructor.
data Property =
  -- Move properties.
    B (Maybe Coord)      -- ^ Black move (nothing iff pass).
  | KO                   -- ^ Execute move unconditionally (even if illegal).
  | MN Integer           -- ^ Assign move number.
  | W (Maybe Coord)      -- ^ White move (nothing iff pass).

  -- Setup properties.
  | AB CoordList         -- ^ Assign black stones.
  | AE CoordList         -- ^ Assign empty stones.
  | AW CoordList         -- ^ Assign white stones.
  | PL Color             -- ^ Player to play.

  -- Node annotation properties.
  | C Text               -- ^ Comment.
  | DM DoubleValue       -- ^ Even position.
  | GB DoubleValue       -- ^ Good for black.
  | GW DoubleValue       -- ^ Good for white.
  | HO DoubleValue       -- ^ Hotspot.
  | N SimpleText         -- ^ Node name.
  | UC DoubleValue       -- ^ Unclear position.
  | V RealValue          -- ^ Node value.

  -- Move annotation properties.
  | BM DoubleValue       -- ^ Bad move.
  | DO                   -- ^ Doubtful move.
  | IT                   -- ^ Interesting move.
  | TE DoubleValue       -- ^ Tesuji.

  -- Markup properties.
  | AR ArrowList         -- ^ Arrows.
  | CR CoordList         -- ^ Mark points with circles.
  | DD CoordList         -- ^ Dim points.
  | LB LabelList         -- ^ Label points with text.
  | LN LineList          -- ^ Lines.
  | MA CoordList         -- ^ Mark points with 'X's.
  | SL CoordList         -- ^ Mark points as selected.
  | SQ CoordList         -- ^ Mark points with squares.
  | TR CoordList         -- ^ Mark points with trianges.

  -- Root properties.
  | AP SimpleText SimpleText -- ^ Application info.
  | CA SimpleText        -- ^ Charset for SimpleText and Text.
  | FF Int               -- ^ File format version.
  | GM Int               -- ^ Game (must be 1 = Go).
  | ST VariationMode     -- ^ Variation display format.
  | SZ Int Int           -- ^ Board size, columns then rows.

  -- Game info properties.
  | AN SimpleText        -- ^ Name of annotator.
  | BR SimpleText        -- ^ Rank of black player.
  | BT SimpleText        -- ^ Name of black team.
  | CP SimpleText        -- ^ Copyright info.
  | DT SimpleText        -- ^ Dates played.
  | EV SimpleText        -- ^ Event name.
  | GC Text              -- ^ Game comment, or background, or summary.
  | GN SimpleText        -- ^ Game name.
  | ON SimpleText        -- ^ Information about the opening.
  | OT SimpleText        -- ^ The method used for overtime.
  | PB SimpleText        -- ^ Name of black player.
  | PC SimpleText        -- ^ Where the game was played.
  | PW SimpleText        -- ^ Name of white player.
  | RE GameResult        -- ^ Result of the game.
  | RO SimpleText        -- ^ Round info.
  | RU Ruleset           -- ^ Ruleset used.
  | SO SimpleText        -- ^ Source of the game.
  | TM RealValue         -- ^ Time limit, in seconds.
  | US SimpleText        -- ^ Name of user or program who entered the game.
  | WR SimpleText        -- ^ Rank of white player.
  | WT SimpleText        -- ^ Name of white team.

  -- Timing properties.
  | BL RealValue         -- ^ Black time left.
  | OB Int               -- ^ Black moves left in byo-yomi period.
  | OW Int               -- ^ White moves left in byo-yomi period.
  | WL RealValue         -- ^ White time left.

  -- Miscellaneous properties.
  -- TODO FG property.
  -- TODO PM property.
  | VW CoordList         -- ^ Set viewing region.

  -- Go-specific properties.
  | HA Int               -- ^ Handicap stones (>=2).
  | KM RealValue         -- ^ Komi.
  | TB CoordList         -- ^ Black territory.
  | TW CoordList         -- ^ White territory.

  | UnknownProperty String UnknownPropertyValue

  -- TODO Game info, timing, and miscellaneous properties.
  -- Also in functions below.
  deriving (Property -> Property -> Bool
(Property -> Property -> Bool)
-> (Property -> Property -> Bool) -> Eq Property
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Property -> Property -> Bool
$c/= :: Property -> Property -> Bool
== :: Property -> Property -> Bool
$c== :: Property -> Property -> Bool
Eq, Int -> Property -> ShowS
[Property] -> ShowS
Property -> String
(Int -> Property -> ShowS)
-> (Property -> String) -> ([Property] -> ShowS) -> Show Property
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Property] -> ShowS
$cshowList :: [Property] -> ShowS
show :: Property -> String
$cshow :: Property -> String
showsPrec :: Int -> Property -> ShowS
$cshowsPrec :: Int -> Property -> ShowS
Show)

-- | The property types that SGF uses to group properties.
data PropertyType = MoveProperty     -- ^ Cannot mix with setup nodes.
                  | SetupProperty    -- ^ Cannot mix with move nodes.
                  | RootProperty     -- ^ May only appear in root nodes.
                  | GameInfoProperty -- ^ At most one on any path.
                  | GeneralProperty  -- ^ May appear anywhere in the game tree.
                  deriving (PropertyType -> PropertyType -> Bool
(PropertyType -> PropertyType -> Bool)
-> (PropertyType -> PropertyType -> Bool) -> Eq PropertyType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PropertyType -> PropertyType -> Bool
$c/= :: PropertyType -> PropertyType -> Bool
== :: PropertyType -> PropertyType -> Bool
$c== :: PropertyType -> PropertyType -> Bool
Eq, Int -> PropertyType -> ShowS
[PropertyType] -> ShowS
PropertyType -> String
(Int -> PropertyType -> ShowS)
-> (PropertyType -> String)
-> ([PropertyType] -> ShowS)
-> Show PropertyType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PropertyType] -> ShowS
$cshowList :: [PropertyType] -> ShowS
show :: PropertyType -> String
$cshow :: PropertyType -> String
showsPrec :: Int -> PropertyType -> ShowS
$cshowsPrec :: Int -> PropertyType -> ShowS
Show)

-- | A class for types that contain metadata about a 'Property'.  The main
-- instance of this class is 'Property' itself; 'Property's can be treated as
-- though they have metadata directly.  When referring to a property in general
-- rather than a specific instance, use the values of 'PropertyInfo' and
-- 'ValuedPropertyInfo'.
--
-- See also 'ValuedDescriptor'.
class Descriptor a where
  -- | Returns the name of the property, as used in SGF files.
  propertyName :: a -> String

  -- | Returns the type of the property, as specified by the SGF spec.
  propertyType :: a -> PropertyType

  -- | Returns whether the value of the given property is inherited from the
  -- lowest ancestor specifying the property, when the property is not set on a
  -- node itself.
  propertyInherited :: a -> Bool

  -- | Returns whether the given property has the type of a descriptor.
  propertyPredicate :: a -> Property -> Bool

  -- | A parser of property values in SGF format (e.g. @"[ab]"@ for a property
  -- that takes a point).
  propertyValueParser :: a -> Parser Property

  -- | A renderer property values to SGF format (e.g. @B (Just (1,2))@ renders
  -- to @"[ab]"@).
  propertyValueRenderer :: a -> Property -> Render ()

  -- | A renderer for displaying property values in a UI.  Displays the value in
  -- a human-readable format.
  propertyValueRendererPretty :: a -> Property -> Render ()

-- | A class for 'Descriptor's of properties that also contain values.
class (Descriptor a, Eq v) => ValuedDescriptor v a | a -> v where
  -- | Extracts the value from a property of the given type.  Behaviour is
  -- undefined if the property is not of the given type.
  propertyValue :: a -> Property -> v

  -- | Builds a property from a given value.
  propertyBuilder :: a -> v -> Property

-- | An existential type for any property descriptor.  'AnyDescriptor' has a
-- 'Descriptor' instance, so there is no need to extract the value with a
-- pattern match before using 'Descriptor' methods.
data AnyDescriptor = forall a. Descriptor a => AnyDescriptor a

instance Descriptor AnyDescriptor where
  propertyName :: AnyDescriptor -> String
propertyName (AnyDescriptor a
d) = a -> String
forall a. Descriptor a => a -> String
propertyName a
d
  propertyType :: AnyDescriptor -> PropertyType
propertyType (AnyDescriptor a
d) = a -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType a
d
  propertyInherited :: AnyDescriptor -> Bool
propertyInherited (AnyDescriptor a
d) = a -> Bool
forall a. Descriptor a => a -> Bool
propertyInherited a
d
  propertyPredicate :: AnyDescriptor -> Property -> Bool
propertyPredicate (AnyDescriptor a
d) = a -> Property -> Bool
forall a. Descriptor a => a -> Property -> Bool
propertyPredicate a
d
  propertyValueParser :: AnyDescriptor -> Parser Property
propertyValueParser (AnyDescriptor a
d) = a -> Parser Property
forall a. Descriptor a => a -> Parser Property
propertyValueParser a
d
  propertyValueRenderer :: AnyDescriptor -> Property -> Render ()
propertyValueRenderer (AnyDescriptor a
d) = a -> Property -> Render ()
forall a. Descriptor a => a -> Property -> Render ()
propertyValueRenderer a
d
  propertyValueRendererPretty :: AnyDescriptor -> Property -> Render ()
propertyValueRendererPretty (AnyDescriptor a
d) = a -> Property -> Render ()
forall a. Descriptor a => a -> Property -> Render ()
propertyValueRendererPretty a
d

-- | An existential type for any descriptor of a property that holds a value of
-- a specific type.  Has instances for 'Descriptor' and 'ValuedDescriptor',
-- similar to 'AnyDescriptor'.
data AnyValuedDescriptor v = forall a. ValuedDescriptor v a => AnyValuedDescriptor a

instance Descriptor (AnyValuedDescriptor v) where
  propertyName :: AnyValuedDescriptor v -> String
propertyName (AnyValuedDescriptor a
d) = a -> String
forall a. Descriptor a => a -> String
propertyName a
d
  propertyType :: AnyValuedDescriptor v -> PropertyType
propertyType (AnyValuedDescriptor a
d) = a -> PropertyType
forall a. Descriptor a => a -> PropertyType
propertyType a
d
  propertyInherited :: AnyValuedDescriptor v -> Bool
propertyInherited (AnyValuedDescriptor a
d) = a -> Bool
forall a. Descriptor a => a -> Bool
propertyInherited a
d
  propertyPredicate :: AnyValuedDescriptor v -> Property -> Bool
propertyPredicate (AnyValuedDescriptor a
d) = a -> Property -> Bool
forall a. Descriptor a => a -> Property -> Bool
propertyPredicate a
d
  propertyValueParser :: AnyValuedDescriptor v -> Parser Property
propertyValueParser (AnyValuedDescriptor a
d) = a -> Parser Property
forall a. Descriptor a => a -> Parser Property
propertyValueParser a
d
  propertyValueRenderer :: AnyValuedDescriptor v -> Property -> Render ()
propertyValueRenderer (AnyValuedDescriptor a
d) = a -> Property -> Render ()
forall a. Descriptor a => a -> Property -> Render ()
propertyValueRenderer a
d
  propertyValueRendererPretty :: AnyValuedDescriptor v -> Property -> Render ()
propertyValueRendererPretty (AnyValuedDescriptor a
d) = a -> Property -> Render ()
forall a. Descriptor a => a -> Property -> Render ()
propertyValueRendererPretty a
d

instance Eq v => ValuedDescriptor v (AnyValuedDescriptor v) where
  propertyValue :: AnyValuedDescriptor v -> Property -> v
propertyValue (AnyValuedDescriptor a
d) = a -> Property -> v
forall v a. ValuedDescriptor v a => a -> Property -> v
propertyValue a
d
  propertyBuilder :: AnyValuedDescriptor v -> v -> Property
propertyBuilder (AnyValuedDescriptor a
d) = a -> v -> Property
forall v a. ValuedDescriptor v a => a -> v -> Property
propertyBuilder a
d

type AnyCoordListDescriptor = AnyValuedDescriptor CoordList

-- | Metadata for a property that does not contain a value.  Corresponds to a
-- nullary data constructor of 'Property'.
data PropertyInfo = PropertyInfo
  { PropertyInfo -> String
propertyInfoName :: String
    -- ^ The SGF textual name for the property.
  , PropertyInfo -> Property
propertyInfoInstance :: Property
    -- ^ The single instance of the property.
  , PropertyInfo -> PropertyType
propertyInfoType :: PropertyType
    -- ^ The SGF property type.
  , PropertyInfo -> Bool
propertyInfoInherited :: Bool
    -- ^ Whether the property is inherited.
  }

instance Descriptor PropertyInfo where
  propertyName :: PropertyInfo -> String
propertyName = PropertyInfo -> String
propertyInfoName
  propertyType :: PropertyInfo -> PropertyType
propertyType = PropertyInfo -> PropertyType
propertyInfoType
  propertyInherited :: PropertyInfo -> Bool
propertyInherited = PropertyInfo -> Bool
propertyInfoInherited
  propertyPredicate :: PropertyInfo -> Property -> Bool
propertyPredicate = Property -> Property -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Property -> Property -> Bool)
-> (PropertyInfo -> Property) -> PropertyInfo -> Property -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyInfo -> Property
propertyInfoInstance
  propertyValueParser :: PropertyInfo -> Parser Property
propertyValueParser PropertyInfo
descriptor = PropertyInfo -> Property
propertyInfoInstance PropertyInfo
descriptor Property -> ParsecT String () Identity () -> Parser Property
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ PropertyValueType () -> ParsecT String () Identity ()
forall a. PropertyValueType a -> Parser a
pvtParser PropertyValueType ()
nonePvt
  propertyValueRenderer :: PropertyInfo -> Property -> Render ()
propertyValueRenderer PropertyInfo
_ Property
_ = PropertyValueType () -> () -> Render ()
forall a. PropertyValueType a -> a -> Render ()
pvtRenderer PropertyValueType ()
nonePvt ()
  propertyValueRendererPretty :: PropertyInfo -> Property -> Render ()
propertyValueRendererPretty PropertyInfo
_ Property
_ = PropertyValueType () -> () -> Render ()
forall a. PropertyValueType a -> a -> Render ()
pvtRendererPretty PropertyValueType ()
nonePvt ()

-- | Metadata for a property that contains a value.  Corresponds to a
-- non-nullary data constructor of 'Property'.
data ValuedPropertyInfo v = ValuedPropertyInfo
  { ValuedPropertyInfo v -> String
valuedPropertyInfoName :: String
    -- ^ The SGF textual name for the property (also the name of the data
    -- constructor).
  , ValuedPropertyInfo v -> PropertyType
valuedPropertyInfoType :: PropertyType
    -- ^ The SGF property type.
  , ValuedPropertyInfo v -> Bool
valuedPropertyInfoInherited :: Bool
    -- ^ Whether the property is inherited.
  , ValuedPropertyInfo v -> Property -> Bool
valuedPropertyInfoPredicate :: Property -> Bool
    -- ^ A predicate that matches predicates to which this 'ValuedPropertyInfo'
    -- applies.
  , ValuedPropertyInfo v -> PropertyValueType v
valuedPropertyInfoValueType :: PropertyValueType v
    -- ^ Metadata about the type of the property's value.
  , ValuedPropertyInfo v -> Property -> v
valuedPropertyInfoValue :: Property -> v
    -- ^ A function that extracts values from properties to which this
    -- 'ValuedPropertyInfo' applies.  It is invalid to call this function with a
    -- different type of property.
  , ValuedPropertyInfo v -> v -> Property
valuedPropertyInfoBuilder :: v -> Property
    -- ^ A function that builds a property containing a value.
  }

instance Descriptor (ValuedPropertyInfo v) where
  propertyName :: ValuedPropertyInfo v -> String
propertyName = ValuedPropertyInfo v -> String
forall v. ValuedPropertyInfo v -> String
valuedPropertyInfoName
  propertyType :: ValuedPropertyInfo v -> PropertyType
propertyType = ValuedPropertyInfo v -> PropertyType
forall v. ValuedPropertyInfo v -> PropertyType
valuedPropertyInfoType
  propertyInherited :: ValuedPropertyInfo v -> Bool
propertyInherited = ValuedPropertyInfo v -> Bool
forall v. ValuedPropertyInfo v -> Bool
valuedPropertyInfoInherited
  propertyPredicate :: ValuedPropertyInfo v -> Property -> Bool
propertyPredicate = ValuedPropertyInfo v -> Property -> Bool
forall v. ValuedPropertyInfo v -> Property -> Bool
valuedPropertyInfoPredicate
  propertyValueParser :: ValuedPropertyInfo v -> Parser Property
propertyValueParser ValuedPropertyInfo v
descriptor =
    (v -> Property) -> ParsecT String () Identity v -> Parser Property
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValuedPropertyInfo v -> v -> Property
forall v. ValuedPropertyInfo v -> v -> Property
valuedPropertyInfoBuilder ValuedPropertyInfo v
descriptor) (ParsecT String () Identity v -> Parser Property)
-> ParsecT String () Identity v -> Parser Property
forall a b. (a -> b) -> a -> b
$
    PropertyValueType v -> ParsecT String () Identity v
forall a. PropertyValueType a -> Parser a
pvtParser (PropertyValueType v -> ParsecT String () Identity v)
-> PropertyValueType v -> ParsecT String () Identity v
forall a b. (a -> b) -> a -> b
$
    ValuedPropertyInfo v -> PropertyValueType v
forall v. ValuedPropertyInfo v -> PropertyValueType v
valuedPropertyInfoValueType ValuedPropertyInfo v
descriptor
  propertyValueRenderer :: ValuedPropertyInfo v -> Property -> Render ()
propertyValueRenderer ValuedPropertyInfo v
descriptor Property
property =
    PropertyValueType v -> v -> Render ()
forall a. PropertyValueType a -> a -> Render ()
pvtRenderer (ValuedPropertyInfo v -> PropertyValueType v
forall v. ValuedPropertyInfo v -> PropertyValueType v
valuedPropertyInfoValueType ValuedPropertyInfo v
descriptor) (v -> Render ()) -> v -> Render ()
forall a b. (a -> b) -> a -> b
$
    ValuedPropertyInfo v -> Property -> v
forall v. ValuedPropertyInfo v -> Property -> v
valuedPropertyInfoValue ValuedPropertyInfo v
descriptor Property
property
  propertyValueRendererPretty :: ValuedPropertyInfo v -> Property -> Render ()
propertyValueRendererPretty ValuedPropertyInfo v
descriptor Property
property =
    PropertyValueType v -> v -> Render ()
forall a. PropertyValueType a -> a -> Render ()
pvtRendererPretty (ValuedPropertyInfo v -> PropertyValueType v
forall v. ValuedPropertyInfo v -> PropertyValueType v
valuedPropertyInfoValueType ValuedPropertyInfo v
descriptor) (v -> Render ()) -> v -> Render ()
forall a b. (a -> b) -> a -> b
$
    ValuedPropertyInfo v -> Property -> v
forall v. ValuedPropertyInfo v -> Property -> v
valuedPropertyInfoValue ValuedPropertyInfo v
descriptor Property
property

instance Eq v => ValuedDescriptor v (ValuedPropertyInfo v) where
  propertyValue :: ValuedPropertyInfo v -> Property -> v
propertyValue = ValuedPropertyInfo v -> Property -> v
forall v. ValuedPropertyInfo v -> Property -> v
valuedPropertyInfoValue
  propertyBuilder :: ValuedPropertyInfo v -> v -> Property
propertyBuilder = ValuedPropertyInfo v -> v -> Property
forall v. ValuedPropertyInfo v -> v -> Property
valuedPropertyInfoBuilder

-- | Internal to this module, do not use outside.  Template Haskell function to
-- declare a property that does not contain a value.
--
-- > $(defProperty "KO" 'MoveProperty False)
--
-- This example declares a @propertyKO :: 'PropertyInfo'@ that is a
-- 'MoveProperty' and is not inherited.
defProperty :: String
               -- ^ The SGF textual name of the property.
            -> Name
               -- ^ The name of the 'PropertyType'.
            -> Bool
               -- ^ Whether the property is inherited.
            -> DecsQ
defProperty :: String -> Name -> Bool -> DecsQ
defProperty String
name Name
propType Bool
inherited = do
  let propName :: Name
propName = String -> Name
mkName String
name
      varName :: Name
varName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"property" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name
  [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
    Name -> TypeQ -> Q Dec
sigD Name
varName (TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"PropertyInfo",
    PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
varName)
         (ExpQ -> BodyQ
normalB [| PropertyInfo name $(conE propName) $(conE propType) inherited |])
         []
    ]

-- | Internal to this module, do not use outside.  Template Haskell function to
-- declare a property that contains a value.
--
-- > $(defValuedProperty "B" 'MoveProperty False 'maybeCoordPrinter)
--
-- This example declares a @propertyB :: 'ValuedPropertyInfo' (Maybe 'Coord')@
-- that is a 'MoveProperty' and is not inherited.  The value type is
-- automatically inferred.
defValuedProperty :: String -> Name -> Bool -> Name -> DecsQ
defValuedProperty :: String -> Name -> Bool -> Name -> DecsQ
defValuedProperty String
name Name
propType Bool
inherited Name
valueType = do
  let propName :: Name
propName = String -> Name
mkName String
name
      varName :: Name
varName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"property" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name
  Name
foo <- String -> Q Name
newName String
"foo"
  Name
bar <- String -> Q Name
newName String
"bar"
#if MIN_VERSION_template_haskell(2,11,0)
  DataConI Name
_ (AppT (AppT Type
_ Type
haskellValueType) Type
_) Name
_ <- Name -> Q Info
reify Name
propName
#else
  DataConI _ (AppT (AppT _ haskellValueType) _) _ _ <- reify propName
#endif
  [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
    Name -> TypeQ -> Q Dec
sigD Name
varName (TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''ValuedPropertyInfo) (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
haskellValueType,
    PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
varName)
         (ExpQ -> BodyQ
normalB [| ValuedPropertyInfo
                     name
                     $(conE propType)
                     inherited
                     $(lam1E (varP foo) $ caseE (varE foo)
                       [match (recP propName [])
                              (normalB $ conE $ mkName "True")
                              [],
                        match wildP (normalB $ conE $ mkName "False") []])
                     $(varE valueType)
                     $(lam1E (varP foo) $ caseE (varE foo)
                       [match (conP propName [varP bar]) (normalB $ varE bar) [],
                        match wildP
                              (normalB
                               [| error $ "Property value getter for " ++ $(stringE name) ++
                                  " applied to " ++ show $(varE foo) ++ "." |])
                              []])
                     $(lam1E (varP foo) $ appE (conE propName) (varE foo))
                   |])
         []
    ]