Skip to content

Parsing Simula's Template Haskell Output

George Singer edited this page Mar 21, 2018 · 8 revisions

Simula ∩ TH

makeLenses

From Control.Lens.TH:

    makeLenses :: Name -> DecsQ

Build lenses (and traversals) with a sensible default configuration.

e.g.

    data FooBar
      = Foo { _x, _y :: Int }
      | Bar { _x :: Int }
    makeLenses ''FooBar

will create

    x :: Lens' FooBar Int
    x f (Foo a b) = (\a' -> Foo a' b) <$> f a
    x f (Bar a)   = Bar <$> f a
    y :: Traversal' FooBar Int
    y f (Foo a b) = (\b' -> Foo a  b') <$> f b
    y _ c@(Bar _) = pure c

For a Simula specific example, consider the datatype

data OpenVRContext = OpenVRContext
  { _vrSystem :: Ptr VR_IVRSystem_FnTable
  , _vrChaperone :: Ptr VR_IVRChaperone_FnTable
  , _vrChaperoneSetup :: Ptr VR_IVRChaperoneSetup_FnTable
  , _vrCompositor :: Ptr VR_IVRCompositor_FnTable
  , _vrOverlay :: Ptr VR_IVROverlay_FnTable
  , _vrResources :: Ptr VR_IVRResources_FnTable
  , _vrRenderModels :: Ptr VR_IVRRenderModels_FnTable
  , _vrExtendedDisplay :: Ptr VR_IVRExtendedDisplay_FnTable
  , _vrSettings :: Ptr VR_IVRSettings_FnTable
  , _vrApplications :: Ptr VR_IVRApplications_FnTable
  , _vrTrackedCamera :: Ptr VR_IVRTrackedCamera_FnTable
  , _vrScreenshots :: Ptr VR_IVRScreenshots_FnTable
  , _vrDriverManager :: Ptr VR_IVRDriverManager_FnTable
  , _vrNotifications :: Ptr VR_IVRNotifications_FnTable }

so that

makeLenses ''OpenVRContext

expands to

vrApplications ::
  Lens' OpenVRContext (Ptr VR_IVRApplications_FnTable)
vrApplications
  f_aXF5
  (OpenVRContext x1_aXF6
                 x2_aXF7
                 x3_aXF8
                 x4_aXF9
                 x5_aXFa
                 x6_aXFb
                 x7_aXFc
                 x8_aXFd
                 x9_aXFe
                 x10_aXFf
                 x11_aXFg
                 x12_aXFh
                 x13_aXFi
                 x14_aXFj)
  = (fmap
       (\ y1_aXFk
          -> (((((((((((((OpenVRContext x1_aXF6) x2_aXF7) x3_aXF8) x4_aXF9)
                        x5_aXFa)
                       x6_aXFb)
                      x7_aXFc)
                     x8_aXFd)
                    x9_aXFe)
                   y1_aXFk)
                  x11_aXFg)
                 x12_aXFh)
                x13_aXFi)
               x14_aXFj))
      (f_aXF5 x10_aXFf)
{-# INLINE vrApplications #-}
vrChaperone :: Lens' OpenVRContext (Ptr VR_IVRChaperone_FnTable)
vrChaperone
  f_aXFl
  (OpenVRContext x1_aXFm
                 x2_aXFn
                 x3_aXFo
                 x4_aXFp
                 x5_aXFq
                 x6_aXFr
                 x7_aXFs
                 x8_aXFt
                 x9_aXFu
                 x10_aXFv
                 x11_aXFw
                 x12_aXFx
                 x13_aXFy
                 x14_aXFz)
  = (fmap
       (\ y1_aXFA
          -> (((((((((((((OpenVRContext x1_aXFm) y1_aXFA) x3_aXFo) x4_aXFp)
                        x5_aXFq)
                       x6_aXFr)
                      x7_aXFs)
                     x8_aXFt)
                    x9_aXFu)
                   x10_aXFv)
                  x11_aXFw)
                 x12_aXFx)
                x13_aXFy)
               x14_aXFz))
      (f_aXFl x2_aXFn)
{-# INLINE vrChaperone #-}
vrChaperoneSetup ::
  Lens' OpenVRContext (Ptr VR_IVRChaperoneSetup_FnTable)
vrChaperoneSetup
  f_aXFB
  (OpenVRContext x1_aXFC
                 x2_aXFD
                 x3_aXFE
                 x4_aXFF
                 x5_aXFG
                 x6_aXFH
                 x7_aXFI
                 x8_aXFJ
                 x9_aXFK
                 x10_aXFL
                 x11_aXFM
                 x12_aXFN
                 x13_aXFO
                 x14_aXFP)
  = (fmap
       (\ y1_aXFQ
          -> (((((((((((((OpenVRContext x1_aXFC) x2_aXFD) y1_aXFQ) x4_aXFF)
                        x5_aXFG)
                       x6_aXFH)
                      x7_aXFI)
                     x8_aXFJ)
                    x9_aXFK)
                   x10_aXFL)
                  x11_aXFM)
                 x12_aXFN)
                x13_aXFO)
               x14_aXFP))
      (f_aXFB x3_aXFE)
{-# INLINE vrChaperoneSetup #-}
vrCompositor :: Lens' OpenVRContext (Ptr VR_IVRCompositor_FnTable)
vrCompositor
  f_aXFR
  (OpenVRContext x1_aXFS
                 x2_aXFT
                 x3_aXFU
                 x4_aXFV
                 x5_aXFW
                 x6_aXFX
                 x7_aXFY
                 x8_aXFZ
                 x9_aXG0
                 x10_aXG1
                 x11_aXG2
                 x12_aXG3
                 x13_aXG4
                 x14_aXG5)
  = (fmap
       (\ y1_aXG6
          -> (((((((((((((OpenVRContext x1_aXFS) x2_aXFT) x3_aXFU) y1_aXG6)
                        x5_aXFW)
                       x6_aXFX)
                      x7_aXFY)
                     x8_aXFZ)
                    x9_aXG0)
                   x10_aXG1)
                  x11_aXG2)
                 x12_aXG3)
                x13_aXG4)
               x14_aXG5))
      (f_aXFR x4_aXFV)
{-# INLINE vrCompositor #-}
vrDriverManager ::
  Lens' OpenVRContext (Ptr VR_IVRDriverManager_FnTable)
vrDriverManager
  f_aXG7
  (OpenVRContext x1_aXG8
                 x2_aXG9
                 x3_aXGa
                 x4_aXGb
                 x5_aXGc
                 x6_aXGd
                 x7_aXGe
                 x8_aXGf
                 x9_aXGg
                 x10_aXGh
                 x11_aXGi
                 x12_aXGj
                 x13_aXGk
                 x14_aXGl)
  = (fmap
       (\ y1_aXGm
          -> (((((((((((((OpenVRContext x1_aXG8) x2_aXG9) x3_aXGa) x4_aXGb)
                        x5_aXGc)
                       x6_aXGd)
                      x7_aXGe)
                     x8_aXGf)
                    x9_aXGg)
                   x10_aXGh)
                  x11_aXGi)
                 x12_aXGj)
                y1_aXGm)
               x14_aXGl))
      (f_aXG7 x13_aXGk)
{-# INLINE vrDriverManager #-}
vrExtendedDisplay ::
  Lens' OpenVRContext (Ptr VR_IVRExtendedDisplay_FnTable)
vrExtendedDisplay
  f_aXGn
  (OpenVRContext x1_aXGo
                 x2_aXGp
                 x3_aXGq
                 x4_aXGr
                 x5_aXGs
                 x6_aXGt
                 x7_aXGu
                 x8_aXGv
                 x9_aXGw
                 x10_aXGx
                 x11_aXGy
                 x12_aXGz
                 x13_aXGA
                 x14_aXGB)
  = (fmap
       (\ y1_aXGC
          -> (((((((((((((OpenVRContext x1_aXGo) x2_aXGp) x3_aXGq) x4_aXGr)
                        x5_aXGs)
                       x6_aXGt)
                      x7_aXGu)
                     y1_aXGC)
                    x9_aXGw)
                   x10_aXGx)
                  x11_aXGy)
                 x12_aXGz)
                x13_aXGA)
               x14_aXGB))
      (f_aXGn x8_aXGv)
{-# INLINE vrExtendedDisplay #-}
vrNotifications ::
  Lens' OpenVRContext (Ptr VR_IVRNotifications_FnTable)
vrNotifications
  f_aXGD
  (OpenVRContext x1_aXGE
                 x2_aXGF
                 x3_aXGG
                 x4_aXGH
                 x5_aXGI
                 x6_aXGJ
                 x7_aXGK
                 x8_aXGL
                 x9_aXGM
                 x10_aXGN
                 x11_aXGO
                 x12_aXGP
                 x13_aXGQ
                 x14_aXGR)
  = (fmap
       (\ y1_aXGS
          -> (((((((((((((OpenVRContext x1_aXGE) x2_aXGF) x3_aXGG) x4_aXGH)
                        x5_aXGI)
                       x6_aXGJ)
                      x7_aXGK)
                     x8_aXGL)
                    x9_aXGM)
                   x10_aXGN)
                  x11_aXGO)
                 x12_aXGP)
                x13_aXGQ)
               y1_aXGS))
      (f_aXGD x14_aXGR)
{-# INLINE vrNotifications #-}
vrOverlay :: Lens' OpenVRContext (Ptr VR_IVROverlay_FnTable)
vrOverlay
  f_aXGT
  (OpenVRContext x1_aXGU
                 x2_aXGV
                 x3_aXGW
                 x4_aXGX
                 x5_aXGY
                 x6_aXGZ
                 x7_aXH0
                 x8_aXH1
                 x9_aXH2
                 x10_aXH3
                 x11_aXH4
                 x12_aXH5
                 x13_aXH6
                 x14_aXH7)
  = (fmap
       (\ y1_aXH8
          -> (((((((((((((OpenVRContext x1_aXGU) x2_aXGV) x3_aXGW) x4_aXGX)
                        y1_aXH8)
                       x6_aXGZ)
                      x7_aXH0)
                     x8_aXH1)
                    x9_aXH2)
                   x10_aXH3)
                  x11_aXH4)
                 x12_aXH5)
                x13_aXH6)
               x14_aXH7))
      (f_aXGT x5_aXGY)
{-# INLINE vrOverlay #-}
vrRenderModels ::
  Lens' OpenVRContext (Ptr VR_IVRRenderModels_FnTable)
vrRenderModels
  f_aXH9
  (OpenVRContext x1_aXHa
                 x2_aXHb
                 x3_aXHc
                 x4_aXHd
                 x5_aXHe
                 x6_aXHf
                 x7_aXHg
                 x8_aXHh
                 x9_aXHi
                 x10_aXHj
                 x11_aXHk
                 x12_aXHl
                 x13_aXHm
                 x14_aXHn)
  = (fmap
       (\ y1_aXHo
          -> (((((((((((((OpenVRContext x1_aXHa) x2_aXHb) x3_aXHc) x4_aXHd)
                        x5_aXHe)
                       x6_aXHf)
                      y1_aXHo)
                     x8_aXHh)
                    x9_aXHi)
                   x10_aXHj)
                  x11_aXHk)
                 x12_aXHl)
                x13_aXHm)
               x14_aXHn))
      (f_aXH9 x7_aXHg)
{-# INLINE vrRenderModels #-}
vrResources :: Lens' OpenVRContext (Ptr VR_IVRResources_FnTable)
vrResources
  f_aXHp
  (OpenVRContext x1_aXHq
                 x2_aXHr
                 x3_aXHs
                 x4_aXHt
                 x5_aXHu
                 x6_aXHv
                 x7_aXHw
                 x8_aXHx
                 x9_aXHy
                 x10_aXHz
                 x11_aXHA
                 x12_aXHB
                 x13_aXHC
                 x14_aXHD)
  = (fmap
       (\ y1_aXHE
          -> (((((((((((((OpenVRContext x1_aXHq) x2_aXHr) x3_aXHs) x4_aXHt)
                        x5_aXHu)
                       y1_aXHE)
                      x7_aXHw)
                     x8_aXHx)
                    x9_aXHy)
                   x10_aXHz)
                  x11_aXHA)
                 x12_aXHB)
                x13_aXHC)
               x14_aXHD))
      (f_aXHp x6_aXHv)
{-# INLINE vrResources #-}
vrScreenshots ::
  Lens' OpenVRContext (Ptr VR_IVRScreenshots_FnTable)
vrScreenshots
  f_aXHF
  (OpenVRContext x1_aXHG
                 x2_aXHH
                 x3_aXHI
                 x4_aXHJ
                 x5_aXHK
                 x6_aXHL
                 x7_aXHM
                 x8_aXHN
                 x9_aXHO
                 x10_aXHP
                 x11_aXHQ
                 x12_aXHR
                 x13_aXHS
                 x14_aXHT)
  = (fmap
       (\ y1_aXHU
          -> (((((((((((((OpenVRContext x1_aXHG) x2_aXHH) x3_aXHI) x4_aXHJ)
                        x5_aXHK)
                       x6_aXHL)
                      x7_aXHM)
                     x8_aXHN)
                    x9_aXHO)
                   x10_aXHP)
                  x11_aXHQ)
                 y1_aXHU)
                x13_aXHS)
               x14_aXHT))
      (f_aXHF x12_aXHR)
{-# INLINE vrScreenshots #-}
vrSettings :: Lens' OpenVRContext (Ptr VR_IVRSettings_FnTable)
vrSettings
  f_aXHV
  (OpenVRContext x1_aXHW
                 x2_aXHX
                 x3_aXHY
                 x4_aXHZ
                 x5_aXI0
                 x6_aXI1
                 x7_aXI2
                 x8_aXI3
                 x9_aXI4
                 x10_aXI5
                 x11_aXI6
                 x12_aXI7
                 x13_aXI8
                 x14_aXI9)
  = (fmap
       (\ y1_aXIa
          -> (((((((((((((OpenVRContext x1_aXHW) x2_aXHX) x3_aXHY) x4_aXHZ)
                        x5_aXI0)
                       x6_aXI1)
                      x7_aXI2)
                     x8_aXI3)
                    y1_aXIa)
                   x10_aXI5)
                  x11_aXI6)
                 x12_aXI7)
                x13_aXI8)
               x14_aXI9))
      (f_aXHV x9_aXI4)
{-# INLINE vrSettings #-}
vrSystem :: Lens' OpenVRContext (Ptr VR_IVRSystem_FnTable)
vrSystem
  f_aXIb
  (OpenVRContext x1_aXIc
                 x2_aXId
                 x3_aXIe
                 x4_aXIf
                 x5_aXIg
                 x6_aXIh
                 x7_aXIi
                 x8_aXIj
                 x9_aXIk
                 x10_aXIl
                 x11_aXIm
                 x12_aXIn
                 x13_aXIo
                 x14_aXIp)
  = (fmap
       (\ y1_aXIq
          -> (((((((((((((OpenVRContext y1_aXIq) x2_aXId) x3_aXIe) x4_aXIf)
                        x5_aXIg)
                       x6_aXIh)
                      x7_aXIi)
                     x8_aXIj)
                    x9_aXIk)
                   x10_aXIl)
                  x11_aXIm)
                 x12_aXIn)
                x13_aXIo)
               x14_aXIp))
      (f_aXIb x1_aXIc)
{-# INLINE vrSystem #-}
vrTrackedCamera ::
  Lens' OpenVRContext (Ptr VR_IVRTrackedCamera_FnTable)
vrTrackedCamera
  f_aXIr
  (OpenVRContext x1_aXIs
                 x2_aXIt
                 x3_aXIu
                 x4_aXIv
                 x5_aXIw
                 x6_aXIx
                 x7_aXIy
                 x8_aXIz
                 x9_aXIA
                 x10_aXIB
                 x11_aXIC
                 x12_aXID
                 x13_aXIE
                 x14_aXIF)
  = (fmap
       (\ y1_aXIG
          -> (((((((((((((OpenVRContext x1_aXIs) x2_aXIt) x3_aXIu) x4_aXIv)
                        x5_aXIw)
                       x6_aXIx)
                      x7_aXIy)
                     x8_aXIz)
                    x9_aXIA)
                   x10_aXIB)
                  y1_aXIG)
                 x12_aXID)
                x13_aXIE)
               x14_aXIF))
      (f_aXIr x11_aXIC)
{-# INLINE vrTrackedCamera #-}

deriveJSON

See here. For a Simula example, consider the datatype

data Const = Const
  { constname :: Text
  , consttype :: Text
  , constval :: Text
  } deriving (Show, Eq)

so that

deriveJSON defaultOptions ''Const

expands to

instance ToJSON Const where
  toJSON
    = \ value_aWVv
        -> case value_aWVv of {
             Const arg1_aWVw arg2_aWVx arg3_aWVy
               -> object
                    [((T.pack "constname") .= (toJSON arg1_aWVw)),
                     ((T.pack "consttype") .= (toJSON arg2_aWVx)),
                     ((T.pack "constval") .= (toJSON arg3_aWVy))] }
  toEncoding
    = \ value_aWVz
        -> case value_aWVz of {
             Const arg1_aWVA arg2_aWVB arg3_aWVC
               -> Data.Aeson.Encoding.Internal.wrapObject
                    (Data.Aeson.TH.commaSep
                       [((Data.Aeson.Encoding.Internal.string "constname")
                           Data.Aeson.Encoding.Internal.><
                             (Data.Aeson.Encoding.Internal.colon
                                Data.Aeson.Encoding.Internal.>< (toEncoding arg1_aWVA))),
                        ((Data.Aeson.Encoding.Internal.string "consttype")
                           Data.Aeson.Encoding.Internal.><
                             (Data.Aeson.Encoding.Internal.colon
                                Data.Aeson.Encoding.Internal.>< (toEncoding arg2_aWVB))),
                        ((Data.Aeson.Encoding.Internal.string "constval")
                           Data.Aeson.Encoding.Internal.><
                             (Data.Aeson.Encoding.Internal.colon
                                Data.Aeson.Encoding.Internal.>< (toEncoding arg3_aWVC)))]) }
instance FromJSON Const where
  parseJSON
    = \ value_aWVD
        -> case value_aWVD of
             Object recObj_aWVE
               -> (((Const
                       <$>
                         (((((Data.Aeson.TH.lookupField parseJSON) "OpenVR.TH.Const")
                              "Const")
                             recObj_aWVE)
                            (T.pack "constname")))
                      <*>
                        (((((Data.Aeson.TH.lookupField parseJSON) "OpenVR.TH.Const")
                             "Const")
                            recObj_aWVE)
                           (T.pack "consttype")))
                     <*>
                       (((((Data.Aeson.TH.lookupField parseJSON) "OpenVR.TH.Const")
                            "Const")
                           recObj_aWVE)
                          (T.pack "constval")))
             other_aWVF
               -> (((Data.Aeson.TH.parseTypeMismatch' "Const") "OpenVR.TH.Const")
                     "Object")
                    (Data.Aeson.TH.valueConName other_aWVF)

parseOpenVRJSON

We have that

parseOpenVRJSON "openvr/headers/openvr_api.json"

expands to

instance VRInterface VR_IVRApplications_FnTable where
  interfaceVersion _ = "IVRApplications_006"
  interface = vrApplications
instance VRInterface VR_IVRChaperone_FnTable where
  interfaceVersion _ = "IVRChaperone_003"
  interface = vrChaperone
instance VRInterface VR_IVRChaperoneSetup_FnTable where
  interfaceVersion _ = "IVRChaperoneSetup_005"
  interface = vrChaperoneSetup
instance VRInterface VR_IVRCompositor_FnTable where
  interfaceVersion _ = "IVRCompositor_022"
  interface = vrCompositor
instance VRInterface VR_IVRDriverManager_FnTable where
  interfaceVersion _ = "IVRDriverManager_001"
  interface = vrDriverManager
instance VRInterface VR_IVRExtendedDisplay_FnTable where
  interfaceVersion _ = "IVRExtendedDisplay_001"
  interface = vrExtendedDisplay
instance VRInterface VR_IVRNotifications_FnTable where
  interfaceVersion _ = "IVRNotifications_002"
  interface = vrNotifications
instance VRInterface VR_IVROverlay_FnTable where
  interfaceVersion _ = "IVROverlay_017"
  interface = vrOverlay
instance VRInterface VR_IVRRenderModels_FnTable where
  interfaceVersion _ = "IVRRenderModels_005"
  interface = vrRenderModels
instance VRInterface VR_IVRResources_FnTable where
  interfaceVersion _ = "IVRResources_001"
  interface = vrResources
instance VRInterface VR_IVRScreenshots_FnTable where
  interfaceVersion _ = "IVRScreenshots_001"
  interface = vrScreenshots
instance VRInterface VR_IVRSettings_FnTable where
  interfaceVersion _ = "IVRSettings_002"
  interface = vrSettings
instance VRInterface VR_IVRSystem_FnTable where
  interfaceVersion _ = "IVRSystem_017"
  interface = vrSystem
instance VRInterface VR_IVRTrackedCamera_FnTable where
  interfaceVersion _ = "IVRTrackedCamera_003"
  interface = vrTrackedCamera
k_pch_MimeType_HomeApp :: String
k_pch_MimeType_HomeApp = "vr/home"
k_pch_MimeType_GameTheater :: String
k_pch_MimeType_GameTheater = "vr/game_theater"
k_pch_Controller_Component_GDC2015 :: String
k_pch_Controller_Component_GDC2015 = "gdc2015"
k_pch_Controller_Component_Base :: String
k_pch_Controller_Component_Base = "base"
k_pch_Controller_Component_Tip :: String
k_pch_Controller_Component_Tip = "tip"
k_pch_Controller_Component_HandGrip :: String
k_pch_Controller_Component_HandGrip = "handgrip"
k_pch_Controller_Component_Status :: String
k_pch_Controller_Component_Status = "status"
k_pch_SteamVR_Section :: String
k_pch_SteamVR_Section = "steamvr"
k_pch_SteamVR_RequireHmd_String :: String
k_pch_SteamVR_RequireHmd_String = "requireHmd"
k_pch_SteamVR_ForcedDriverKey_String :: String
k_pch_SteamVR_ForcedDriverKey_String = "forcedDriver"
k_pch_SteamVR_ForcedHmdKey_String :: String
k_pch_SteamVR_ForcedHmdKey_String = "forcedHmd"
k_pch_SteamVR_DisplayDebug_Bool :: String
k_pch_SteamVR_DisplayDebug_Bool = "displayDebug"
k_pch_SteamVR_DebugProcessPipe_String :: String
k_pch_SteamVR_DebugProcessPipe_String = "debugProcessPipe"
k_pch_SteamVR_DisplayDebugX_Int32 :: String
k_pch_SteamVR_DisplayDebugX_Int32 = "displayDebugX"
k_pch_SteamVR_DisplayDebugY_Int32 :: String
k_pch_SteamVR_DisplayDebugY_Int32 = "displayDebugY"
k_pch_SteamVR_SendSystemButtonToAllApps_Bool :: String
k_pch_SteamVR_SendSystemButtonToAllApps_Bool
  = "sendSystemButtonToAllApps"
k_pch_SteamVR_LogLevel_Int32 :: String
k_pch_SteamVR_LogLevel_Int32 = "loglevel"
k_pch_SteamVR_IPD_Float :: String
k_pch_SteamVR_IPD_Float = "ipd"
k_pch_SteamVR_Background_String :: String
k_pch_SteamVR_Background_String = "background"
k_pch_SteamVR_BackgroundUseDomeProjection_Bool :: String
k_pch_SteamVR_BackgroundUseDomeProjection_Bool
  = "backgroundUseDomeProjection"
k_pch_SteamVR_BackgroundCameraHeight_Float :: String
k_pch_SteamVR_BackgroundCameraHeight_Float
  = "backgroundCameraHeight"
k_pch_SteamVR_BackgroundDomeRadius_Float :: String
k_pch_SteamVR_BackgroundDomeRadius_Float = "backgroundDomeRadius"
k_pch_SteamVR_GridColor_String :: String
k_pch_SteamVR_GridColor_String = "gridColor"
k_pch_SteamVR_PlayAreaColor_String :: String
k_pch_SteamVR_PlayAreaColor_String = "playAreaColor"
k_pch_SteamVR_ShowStage_Bool :: String
k_pch_SteamVR_ShowStage_Bool = "showStage"
k_pch_SteamVR_ActivateMultipleDrivers_Bool :: String
k_pch_SteamVR_ActivateMultipleDrivers_Bool
  = "activateMultipleDrivers"
k_pch_SteamVR_DirectMode_Bool :: String
k_pch_SteamVR_DirectMode_Bool = "directMode"
k_pch_SteamVR_DirectModeEdidVid_Int32 :: String
k_pch_SteamVR_DirectModeEdidVid_Int32 = "directModeEdidVid"
k_pch_SteamVR_DirectModeEdidPid_Int32 :: String
k_pch_SteamVR_DirectModeEdidPid_Int32 = "directModeEdidPid"
k_pch_SteamVR_UsingSpeakers_Bool :: String
k_pch_SteamVR_UsingSpeakers_Bool = "usingSpeakers"
k_pch_SteamVR_SpeakersForwardYawOffsetDegrees_Float :: String
k_pch_SteamVR_SpeakersForwardYawOffsetDegrees_Float
  = "speakersForwardYawOffsetDegrees"
k_pch_SteamVR_BaseStationPowerManagement_Bool :: String
k_pch_SteamVR_BaseStationPowerManagement_Bool
  = "basestationPowerManagement"
k_pch_SteamVR_NeverKillProcesses_Bool :: String
k_pch_SteamVR_NeverKillProcesses_Bool = "neverKillProcesses"
k_pch_SteamVR_SupersampleScale_Float :: String
k_pch_SteamVR_SupersampleScale_Float = "supersampleScale"
k_pch_SteamVR_AllowAsyncReprojection_Bool :: String
k_pch_SteamVR_AllowAsyncReprojection_Bool
  = "allowAsyncReprojection"
k_pch_SteamVR_AllowReprojection_Bool :: String
k_pch_SteamVR_AllowReprojection_Bool
  = "allowInterleavedReprojection"
k_pch_SteamVR_ForceReprojection_Bool :: String
k_pch_SteamVR_ForceReprojection_Bool = "forceReprojection"
k_pch_SteamVR_ForceFadeOnBadTracking_Bool :: String
k_pch_SteamVR_ForceFadeOnBadTracking_Bool
  = "forceFadeOnBadTracking"
k_pch_SteamVR_DefaultMirrorView_Int32 :: String
k_pch_SteamVR_DefaultMirrorView_Int32 = "defaultMirrorView"
k_pch_SteamVR_ShowMirrorView_Bool :: String
k_pch_SteamVR_ShowMirrorView_Bool = "showMirrorView"
k_pch_SteamVR_MirrorViewGeometry_String :: String
k_pch_SteamVR_MirrorViewGeometry_String = "mirrorViewGeometry"
k_pch_SteamVR_StartMonitorFromAppLaunch :: String
k_pch_SteamVR_StartMonitorFromAppLaunch
  = "startMonitorFromAppLaunch"
k_pch_SteamVR_StartCompositorFromAppLaunch_Bool :: String
k_pch_SteamVR_StartCompositorFromAppLaunch_Bool
  = "startCompositorFromAppLaunch"
k_pch_SteamVR_StartDashboardFromAppLaunch_Bool :: String
k_pch_SteamVR_StartDashboardFromAppLaunch_Bool
  = "startDashboardFromAppLaunch"
k_pch_SteamVR_StartOverlayAppsFromDashboard_Bool :: String
k_pch_SteamVR_StartOverlayAppsFromDashboard_Bool
  = "startOverlayAppsFromDashboard"
k_pch_SteamVR_EnableHomeApp :: String
k_pch_SteamVR_EnableHomeApp = "enableHomeApp"
k_pch_SteamVR_CycleBackgroundImageTimeSec_Int32 :: String
k_pch_SteamVR_CycleBackgroundImageTimeSec_Int32
  = "CycleBackgroundImageTimeSec"
k_pch_SteamVR_RetailDemo_Bool :: String
k_pch_SteamVR_RetailDemo_Bool = "retailDemo"
k_pch_SteamVR_IpdOffset_Float :: String
k_pch_SteamVR_IpdOffset_Float = "ipdOffset"
k_pch_SteamVR_AllowSupersampleFiltering_Bool :: String
k_pch_SteamVR_AllowSupersampleFiltering_Bool
  = "allowSupersampleFiltering"
k_pch_SteamVR_EnableLinuxVulkanAsync_Bool :: String
k_pch_SteamVR_EnableLinuxVulkanAsync_Bool
  = "enableLinuxVulkanAsync"
k_pch_SteamVR_HaveStartedTutorialForNativeChaperoneDriver_Bool ::
  String
k_pch_SteamVR_HaveStartedTutorialForNativeChaperoneDriver_Bool
  = "haveStartedTutorialForNativeChaperoneDriver"
k_pch_Lighthouse_Section :: String
k_pch_Lighthouse_Section = "driver_lighthouse"
k_pch_Lighthouse_DisableIMU_Bool :: String
k_pch_Lighthouse_DisableIMU_Bool = "disableimu"
k_pch_Lighthouse_UseDisambiguation_String :: String
k_pch_Lighthouse_UseDisambiguation_String = "usedisambiguation"
k_pch_Lighthouse_DisambiguationDebug_Int32 :: String
k_pch_Lighthouse_DisambiguationDebug_Int32 = "disambiguationdebug"
k_pch_Lighthouse_PrimaryBasestation_Int32 :: String
k_pch_Lighthouse_PrimaryBasestation_Int32 = "primarybasestation"
k_pch_Lighthouse_DBHistory_Bool :: String
k_pch_Lighthouse_DBHistory_Bool = "dbhistory"
k_pch_Lighthouse_EnableBluetooth_Bool :: String
k_pch_Lighthouse_EnableBluetooth_Bool = "enableBluetooth"
k_pch_Null_Section :: String
k_pch_Null_Section = "driver_null"
k_pch_Null_SerialNumber_String :: String
k_pch_Null_SerialNumber_String = "serialNumber"
k_pch_Null_ModelNumber_String :: String
k_pch_Null_ModelNumber_String = "modelNumber"
k_pch_Null_WindowX_Int32 :: String
k_pch_Null_WindowX_Int32 = "windowX"
k_pch_Null_WindowY_Int32 :: String
k_pch_Null_WindowY_Int32 = "windowY"
k_pch_Null_WindowWidth_Int32 :: String
k_pch_Null_WindowWidth_Int32 = "windowWidth"
k_pch_Null_WindowHeight_Int32 :: String
k_pch_Null_WindowHeight_Int32 = "windowHeight"
k_pch_Null_RenderWidth_Int32 :: String
k_pch_Null_RenderWidth_Int32 = "renderWidth"
k_pch_Null_RenderHeight_Int32 :: String
k_pch_Null_RenderHeight_Int32 = "renderHeight"
k_pch_Null_SecondsFromVsyncToPhotons_Float :: String
k_pch_Null_SecondsFromVsyncToPhotons_Float
  = "secondsFromVsyncToPhotons"
k_pch_Null_DisplayFrequency_Float :: String
k_pch_Null_DisplayFrequency_Float = "displayFrequency"
k_pch_UserInterface_Section :: String
k_pch_UserInterface_Section = "userinterface"
k_pch_UserInterface_StatusAlwaysOnTop_Bool :: String
k_pch_UserInterface_StatusAlwaysOnTop_Bool = "StatusAlwaysOnTop"
k_pch_UserInterface_MinimizeToTray_Bool :: String
k_pch_UserInterface_MinimizeToTray_Bool = "MinimizeToTray"
k_pch_UserInterface_Screenshots_Bool :: String
k_pch_UserInterface_Screenshots_Bool = "screenshots"
k_pch_UserInterface_ScreenshotType_Int :: String
k_pch_UserInterface_ScreenshotType_Int = "screenshotType"
k_pch_Notifications_Section :: String
k_pch_Notifications_Section = "notifications"
k_pch_Notifications_DoNotDisturb_Bool :: String
k_pch_Notifications_DoNotDisturb_Bool = "DoNotDisturb"
k_pch_Keyboard_Section :: String
k_pch_Keyboard_Section = "keyboard"
k_pch_Keyboard_TutorialCompletions :: String
k_pch_Keyboard_TutorialCompletions = "TutorialCompletions"
k_pch_Keyboard_ScaleX :: String
k_pch_Keyboard_ScaleX = "ScaleX"
k_pch_Keyboard_ScaleY :: String
k_pch_Keyboard_ScaleY = "ScaleY"
k_pch_Keyboard_OffsetLeftX :: String
k_pch_Keyboard_OffsetLeftX = "OffsetLeftX"
k_pch_Keyboard_OffsetRightX :: String
k_pch_Keyboard_OffsetRightX = "OffsetRightX"
k_pch_Keyboard_OffsetY :: String
k_pch_Keyboard_OffsetY = "OffsetY"
k_pch_Keyboard_Smoothing :: String
k_pch_Keyboard_Smoothing = "Smoothing"
k_pch_Perf_Section :: String
k_pch_Perf_Section = "perfcheck"
k_pch_Perf_HeuristicActive_Bool :: String
k_pch_Perf_HeuristicActive_Bool = "heuristicActive"
k_pch_Perf_NotifyInHMD_Bool :: String
k_pch_Perf_NotifyInHMD_Bool = "warnInHMD"
k_pch_Perf_NotifyOnlyOnce_Bool :: String
k_pch_Perf_NotifyOnlyOnce_Bool = "warnOnlyOnce"
k_pch_Perf_AllowTimingStore_Bool :: String
k_pch_Perf_AllowTimingStore_Bool = "allowTimingStore"
k_pch_Perf_SaveTimingsOnExit_Bool :: String
k_pch_Perf_SaveTimingsOnExit_Bool = "saveTimingsOnExit"
k_pch_Perf_TestData_Float :: String
k_pch_Perf_TestData_Float = "perfTestData"
k_pch_Perf_LinuxGPUProfiling_Bool :: String
k_pch_Perf_LinuxGPUProfiling_Bool = "linuxGPUProfiling"
k_pch_CollisionBounds_Section :: String
k_pch_CollisionBounds_Section = "collisionBounds"
k_pch_CollisionBounds_Style_Int32 :: String
k_pch_CollisionBounds_Style_Int32 = "CollisionBoundsStyle"
k_pch_CollisionBounds_GroundPerimeterOn_Bool :: String
k_pch_CollisionBounds_GroundPerimeterOn_Bool
  = "CollisionBoundsGroundPerimeterOn"
k_pch_CollisionBounds_CenterMarkerOn_Bool :: String
k_pch_CollisionBounds_CenterMarkerOn_Bool
  = "CollisionBoundsCenterMarkerOn"
k_pch_CollisionBounds_PlaySpaceOn_Bool :: String
k_pch_CollisionBounds_PlaySpaceOn_Bool
  = "CollisionBoundsPlaySpaceOn"
k_pch_CollisionBounds_FadeDistance_Float :: String
k_pch_CollisionBounds_FadeDistance_Float
  = "CollisionBoundsFadeDistance"
k_pch_CollisionBounds_ColorGammaR_Int32 :: String
k_pch_CollisionBounds_ColorGammaR_Int32
  = "CollisionBoundsColorGammaR"
k_pch_CollisionBounds_ColorGammaG_Int32 :: String
k_pch_CollisionBounds_ColorGammaG_Int32
  = "CollisionBoundsColorGammaG"
k_pch_CollisionBounds_ColorGammaB_Int32 :: String
k_pch_CollisionBounds_ColorGammaB_Int32
  = "CollisionBoundsColorGammaB"
k_pch_CollisionBounds_ColorGammaA_Int32 :: String
k_pch_CollisionBounds_ColorGammaA_Int32
  = "CollisionBoundsColorGammaA"
k_pch_Camera_Section :: String
k_pch_Camera_Section = "camera"
k_pch_Camera_EnableCamera_Bool :: String
k_pch_Camera_EnableCamera_Bool = "enableCamera"
k_pch_Camera_EnableCameraInDashboard_Bool :: String
k_pch_Camera_EnableCameraInDashboard_Bool
  = "enableCameraInDashboard"
k_pch_Camera_EnableCameraForCollisionBounds_Bool :: String
k_pch_Camera_EnableCameraForCollisionBounds_Bool
  = "enableCameraForCollisionBounds"
k_pch_Camera_EnableCameraForRoomView_Bool :: String
k_pch_Camera_EnableCameraForRoomView_Bool
  = "enableCameraForRoomView"
k_pch_Camera_BoundsColorGammaR_Int32 :: String
k_pch_Camera_BoundsColorGammaR_Int32 = "cameraBoundsColorGammaR"
k_pch_Camera_BoundsColorGammaG_Int32 :: String
k_pch_Camera_BoundsColorGammaG_Int32 = "cameraBoundsColorGammaG"
k_pch_Camera_BoundsColorGammaB_Int32 :: String
k_pch_Camera_BoundsColorGammaB_Int32 = "cameraBoundsColorGammaB"
k_pch_Camera_BoundsColorGammaA_Int32 :: String
k_pch_Camera_BoundsColorGammaA_Int32 = "cameraBoundsColorGammaA"
k_pch_Camera_BoundsStrength_Int32 :: String
k_pch_Camera_BoundsStrength_Int32 = "cameraBoundsStrength"
k_pch_audio_Section :: String
k_pch_audio_Section = "audio"
k_pch_audio_OnPlaybackDevice_String :: String
k_pch_audio_OnPlaybackDevice_String = "onPlaybackDevice"
k_pch_audio_OnRecordDevice_String :: String
k_pch_audio_OnRecordDevice_String = "onRecordDevice"
k_pch_audio_OnPlaybackMirrorDevice_String :: String
k_pch_audio_OnPlaybackMirrorDevice_String
  = "onPlaybackMirrorDevice"
k_pch_audio_OffPlaybackDevice_String :: String
k_pch_audio_OffPlaybackDevice_String = "offPlaybackDevice"
k_pch_audio_OffRecordDevice_String :: String
k_pch_audio_OffRecordDevice_String = "offRecordDevice"
k_pch_audio_VIVEHDMIGain :: String
k_pch_audio_VIVEHDMIGain = "viveHDMIGain"
k_pch_Power_Section :: String
k_pch_Power_Section = "power"
k_pch_Power_PowerOffOnExit_Bool :: String
k_pch_Power_PowerOffOnExit_Bool = "powerOffOnExit"
k_pch_Power_TurnOffScreensTimeout_Float :: String
k_pch_Power_TurnOffScreensTimeout_Float = "turnOffScreensTimeout"
k_pch_Power_TurnOffControllersTimeout_Float :: String
k_pch_Power_TurnOffControllersTimeout_Float
  = "turnOffControllersTimeout"
k_pch_Power_ReturnToWatchdogTimeout_Float :: String
k_pch_Power_ReturnToWatchdogTimeout_Float
  = "returnToWatchdogTimeout"
k_pch_Power_AutoLaunchSteamVROnButtonPress :: String
k_pch_Power_AutoLaunchSteamVROnButtonPress
  = "autoLaunchSteamVROnButtonPress"
k_pch_Power_PauseCompositorOnStandby_Bool :: String
k_pch_Power_PauseCompositorOnStandby_Bool
  = "pauseCompositorOnStandby"
k_pch_Dashboard_Section :: String
k_pch_Dashboard_Section = "dashboard"
k_pch_Dashboard_EnableDashboard_Bool :: String
k_pch_Dashboard_EnableDashboard_Bool = "enableDashboard"
k_pch_Dashboard_ArcadeMode_Bool :: String
k_pch_Dashboard_ArcadeMode_Bool = "arcadeMode"
k_pch_modelskin_Section :: String
k_pch_modelskin_Section = "modelskins"
k_pch_Driver_Enable_Bool :: String
k_pch_Driver_Enable_Bool = "enable"
k_nDriverNone :: Int
k_nDriverNone = 4294967295
k_unMaxDriverDebugResponseSize :: Int
k_unMaxDriverDebugResponseSize = 32768
k_unTrackedDeviceIndex_Hmd :: Int
k_unTrackedDeviceIndex_Hmd = 0
k_unMaxTrackedDeviceCount :: Int
k_unMaxTrackedDeviceCount = 64
k_unTrackedDeviceIndexOther :: Int
k_unTrackedDeviceIndexOther = 4294967294
k_unTrackedDeviceIndexInvalid :: Int
k_unTrackedDeviceIndexInvalid = 4294967295
k_unMaxPropertyStringSize :: Int
k_unMaxPropertyStringSize = 32768
k_unControllerStateAxisCount :: Int
k_unControllerStateAxisCount = 5
k_unScreenshotHandleInvalid :: Int
k_unScreenshotHandleInvalid = 0
k_unMaxApplicationKeyLength :: Int
k_unMaxApplicationKeyLength = 128
k_unVROverlayMaxKeyLength :: Int
k_unVROverlayMaxKeyLength = 128
k_unVROverlayMaxNameLength :: Int
k_unVROverlayMaxNameLength = 128
k_unMaxOverlayCount :: Int
k_unMaxOverlayCount = 64
k_unMaxOverlayIntersectionMaskPrimitivesCount :: Int
k_unMaxOverlayIntersectionMaskPrimitivesCount = 32
k_unNotificationTextMaxSize :: Int
k_unNotificationTextMaxSize = 256
k_unMaxSettingsKeyLength :: Int
k_unMaxSettingsKeyLength = 128

makeVrCall

Consider

makeVrCall 'ivrCompositorSubmit_ "ivrCompositorSubmit" 

To understand what this expands to, we can work backwards from the C++ function vr::IVRCompositor::Submit(..) from openvr.h:

namespace vr
{
  class IVRCompositor
  {
  public:
    //...
    virtual EVRCompositorError Submit( EVREye eEye, const Texture_t *pTexture, const VRTextureBounds_t* pBounds = 0, EVRSubmitFlags nSubmitFlags = Submit_Default ) = 0;
    //...
  };
}

In this context, the class IVRCompositor gives rise to two objects:

  1. A virtual table. Since Submit(..) is virtual, our C++ compiler will implicitly insert a (static) pointer to a virtual table in IVRCompositor. This virtual table is itself an array of pointers to (virtual) functions. It contains the addresses of functions which implement the virtual methods of IVRCompositor, so that the proper one can be called at runtime.
  2. A virtual pointer. If instanceIVRCompositor is an instance of vr::IVRCompositor, then our C++ compiler will also implicitly create a pointer to the virtual table described in (1), and make it an instance variable of instanceIVRCompositor. In C++, this hidden virtual pointer is retrieved behind the scenes from this, so that C++ calls to Submit(..) are implicitly resolved as Submit(this, ..) (or, for our purposes, as Submit(vpointer, ..)) by the compiler.

With this in mind, consider the c2hs function ivrCompositorSubmit_:

-- Internal.chs
{#fun VR_IVRCompositor_FnTable->Submit as ivrCompositorSubmit_
      { coerce `VR_IVRCompositor_FnTable'      -- <-- virtual table
      , castPtr `Ptr VR_IVRCompositor_FnTable' -- <-- virtual pointer to virtual table
      , `EVREye'
      , `TexturePtr'
      , `VRTextureBounds_t'
, `EVRSubmitFlags' } -> `EVRCompositorError' #}

The function ivrCompositorSubmit_ emulates a C++ call to vr::IVRCompositor::Submit(..). Since we’re in Haskell and not C++, this function requires us to supply as first argument a VR_IVRCompositor_FnTable (i.e., IVRCompositor’s static virtual table), and as second argument a Ptr VR_IVRCompositor_FnTable (i.e., a vpointer which would normally be accessed from this).

Fortunately, we don’t actually use ivrCompositorSubmit_ in Simula; instead, we use ivrCompositorSubmit:

makeVrCall 'ivrCompositorSubmit_ "ivrCompositorSubmit"

Here, ivrCompositorSubmit is a version of ivrCompositorSubmit_ that is automatically supplied with its first two arguments. In particular, we have that

makeVrCall 'ivrCompositorSubmit_ "ivrCompositorSubmit"

expands to

ivrCompositorSubmit ::
  EVREye
  -> TexturePtr
     -> VRTextureBounds_t -> EVRSubmitFlags -> IO EVRCompositorError
ivrCompositorSubmit
  = \ x_aY6M x_aY6N x_aY6O x_aY6P
      -> do ctx_aY6Q <- getOpenVRContext         
            let ptr_aY6S = (view interface) ctx                             -- <-- Simula keeps ONE instance of an IVRCompositor alive, whose vpointer is accessed here through some black magic that isn't important to understand
            vtbl_aY6R <- peek ptr_aY6S                                      -- <-- We then peek this vpointer to get the actual vr::IVRCompositor vtable
            (((((ivrCompositorSubmit_ vtbl_aY6R) ptr_aY6S) x_aY6M) x_aY6N)  -- <-- We then jam the vtable and vpointer as the two arguments to ivrCompositorSubmit_
               x_aY6O)
              x_aY6P

Through some black magic that isn’t important to understand, ivrCompositorSubmit emulates a call to ivrCompositorSubmit_ with its first two arguments supplied.

In conclusion, the following calls to vr::IVRCompositor::Submit(..) are all three equivalent to each other.

  1. ivrCompositorSubmit ..
  2. ivrCompositorSubmit_ IVRCompositorVTable globalIVRCompositorIntance ..
  3. globalIVRCompositorInstance->Submit(..)

Techniques for Viewing TH Output

-ddump-splices

As a cabal option

In *.cabal or package.yaml, add

ghc-options: -ddump-splices

After building, stack generates *.dump-* files inside .stack-work, which can be retrieved via

$ find . -name "*.dump-*"

Setting this option also causes TH splices to be displayed first thing to the console when launching stack ghci.

As a GHCi Option

*OpenVR.Interface> :set -ddump-splices
*OpenVR.Interface> :l src/OpenVR/Interface.hs -- this will dump the splices of Interface.hs to the REPL

Parsing Q [Dec] in GHCi

Consider a snippet from simula-openvr:

parseOpenVRJSON "openvr/headers/openvr_api.json"

Noting that parseOpenVRJSON :: FilePath -> Q [Dec], it is not clear what this expands to. To solve the problem, open up a GHCi in simula-openvr and add the following helper function:

*OpenVR.TH OpenVR OpenVR.Interface OpenVR.Internal OpenVR.TH> :{
printDecs decs = do
  expr <- runQ decs
  putStrLn $ pprint expr
:}

This allows us to take a term of type Q [Dec] and pretty print it to the GHCi REPL. In particular, we can use it on parseOpenVRJSON:

> printDecs $ parseOpenVRJSON "openvr/headers/openvr_api.json"
-- ...output...

Capture

https://en.wikipedia.org/wiki/Virtual_method_table

David Discussion

Ok so in `openvr.h` we have:

class COpenVRContext
	{
	public:
  //...
    IVRSystem *VRSystem()
        {
          CheckClear();
          if ( m_pVRSystem == nullptr )
          {
            EVRInitError eError;
            m_pVRSystem = ( IVRSystem * )VR_GetGenericInterface( IVRSystem_Version, &eError );
          }
          return m_pVRSystem;
        }

  //...
  };

Here, `VRSystem()` is a method that takes no arguments and returns a `IVRSystem *`. But you’re saying this is actually a `this` pointer, which is a vpointer of an instance of a `IVRCompositor`?