Commit e814184c authored by sheaf's avatar sheaf
Browse files

GHC 9.2 compatibility

parent 8bf95a06
......@@ -11,6 +11,7 @@ allow-newer:
, *:ghc
, *:ghc-prim
, *:template-haskell
, ghc-typelits-natnormalise:ghc-bignum
, *:lens
, lens:Cabal
......@@ -22,13 +23,5 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/ekmett/lens
tag: 5b53b48a9c7a5cfcc4eb9b3dd0f7834a4acbdfa0
source-repository-package
type: git
location: https://github.com/sheaf/packages
tag: cd259b94ce5a6dd0c15b4368198fb2a205c32b92
subdir: haskus-utils-data
subdir: haskus-utils-variant
subdir: haskus-utils-types
location: https://github.com/sheaf/typelits-witnesses
tag: 5db7b553a3bf2c5bb98da0abf3ab37115c078df9
......@@ -20,6 +20,8 @@ allow-newer:
, *:template-haskell
, *:lens
, lens:Cabal
, ghc-typelits-natnormalise:ghc-bignum
, sdl2:bytestring
source-repository-package
type: git
......@@ -28,21 +30,24 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/ekmett/lens
tag: 5b53b48a9c7a5cfcc4eb9b3dd0f7834a4acbdfa0
location: https://github.com/tfausak/unix-compat
tag: 154c3a63f154cb49c51d5f9d13488e8119631d8a
source-repository-package
type: git
location: https://github.com/sheaf/packages
tag: cd259b94ce5a6dd0c15b4368198fb2a205c32b92
subdir: haskus-utils-data
subdir: haskus-utils-variant
subdir: haskus-utils-types
location: https://github.com/sheaf/generic-lens
tag: c265eb236c8264a8a06241d6ea04443a6803c92c
source-repository-package
type: git
location: https://github.com/sheaf/generic-lens
tag: e2b4e7d77beaa094c8137b9f7a1f860a6469d837
location: https://github.com/sheaf/typelits-witnesses
tag: 5db7b553a3bf2c5bb98da0abf3ab37115c078df9
-- Crucial bug fix for GHC 9.2 (alignment error)
source-repository-package
type: git
location: https://github.com/haskell-game/sdl2
tag: e9b0b6910b10de44c26d99dcb0b144299970f56b
package dear-imgui
flags: +sdl2 -glfw -opengl2 -opengl3 +vulkan -examples
......@@ -20,6 +20,10 @@ module FIR.Examples.RayTracing.Estimator
( estimateRadiance )
where
-- base
import Data.Proxy
( Proxy(..) )
-- fir
import FIR
import Math.Linear
......@@ -42,16 +46,17 @@ import FIR.Examples.RayTracing.Types
--------------------------------------------------------------------------
type HasRW s name ty = ( Has name s ~ ty, CanGet name s, CanPut name s )
type Luminaires = Struct '[ "luminaireArray" ':-> RuntimeArray LuminaireID ]
estimateRadiance
:: forall s
:: forall (s :: ProgramState)
. ( HasRW s "payload" PrimaryPayload
, HasRW s "occPayload" OcclusionPayload
, HasRW s "emitterData" EmitterCallableData
, HasRW s "matSampleData" MaterialSampleCallableData
, HasRW s "matQueryData" MaterialQueryCallableData
, HasRW s "lightSampleData" LightSamplingCallableData
, Has "luminaires" s ~ ( Struct '[ "luminaireArray" ':-> RuntimeArray LuminaireID ] )
, Has "luminaires" s ~ Luminaires
, CanGet "luminaires" s
, CanTraceRay "occPayload" s
, CanExecuteCallable "emitterData" s
......@@ -61,12 +66,13 @@ estimateRadiance
, QuasiRandom s
, _
)
=> Code AccelerationStructure
=> Proxy s -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/20921
-> Code AccelerationStructure
-> Code ShaderRecord
-> Code ( V 3 Float ) -- ^ World position of hit.
-> Code ( V 3 Float ) -- ^ Normal vector to surface at hit point.
-> Program s s ( Code () )
estimateRadiance accel shaderRecord hitPos normal = do
estimateRadiance _ accel shaderRecord hitPos normal = do
prevHitType <- use @( Name "payload" :.: Name "hitType" )
rayOrigin <- use @( Name "payload" :.: Name "worldRayOrigin" )
......@@ -94,7 +100,7 @@ estimateRadiance accel shaderRecord hitPos normal = do
emitterCallable <- let' $ view @( Name "emitterCallable" ) shaderRecord
when ( specular prevHitType && emitterCallable >= 0 ) do
-- Pass the data that the callable shader needs.
emitterInfoIndex <- let' $ view @( Name "emitterInfoIndex" ) shaderRecord
put @"emitterData" ( Struct $ emitterInfoIndex :& rayDirection :& normal :& wavelengths :& End )
......@@ -172,6 +178,7 @@ estimateRadiance accel shaderRecord hitPos normal = do
lg <- arrayLength @( Name "luminaires" :.: Index 0 )
unless ( lg < 1 ) do
luminaire <- randomLuminaire lg
--lumWeight <- let' $ view @( Name "luminaireWeight" ) luminaire
lightPrimitiveID <- let' $ view @( Name "primitiveID" ) luminaire
......@@ -238,7 +245,7 @@ estimateRadiance accel shaderRecord hitPos normal = do
put @"matQueryData"
( Struct $ materialInfoIndex :& normal :& rayDirection :& lightDirection :& wavelengths :& extinctionCoeffs :& Vec4 1 1 1 1 :& Vec4 0 0 0 0 :& End )
executeCallable @"matQueryData" materialQueryCallable
-- Obtain results.
lightDirBSDF <- use @( Name "matQueryData" :.: Name "bsdf" )
lightDirProb <- use @( Name "matQueryData" :.: Name "probs" )
......@@ -250,7 +257,7 @@ estimateRadiance accel shaderRecord hitPos normal = do
mis
( (*) <$$> bounceDirBSDF <**> bounceEmitterRadiances ) ( bounceDirProb ^* p_λ )
( (*) <$$> lightDirBSDF <**> lightSampleEmitterRadiances ) ( lightDirProb ^* ( p_λ * psa_correction ) )
modifying @( Name "payload" :.: Name "radiance" ) ( ^+^ ( (*) <$$> throughput <**> estimatedRadiance ) )
-- Update the ray throughput using BSDF values.
......@@ -296,23 +303,30 @@ russianRoulette ( Vec4 t1 t2 t3 t4 ) = do
then recip continueProb
else (-1)
-- Defining this synonym because GHC 9.2 gets confused about kinds if I don't write the
-- return kind (RuntimeArray LuminaireID) explicitly.
type LuminaireArray = Name "luminaireArray" :: Optic '[] Luminaires (RuntimeArray LuminaireID)
type Luminaire = Name "luminaires" :.: LuminaireArray :.: AnIndex Word32 :: Optic '[ Word32 ] s LuminaireID
-- | Randomly choose a scene light, with probability
-- proportional to its weight in the given array of all scene lights.
--
-- The total weight (i.e. sum of each light's weight) must be 1.
randomLuminaire
:: ( QuasiRandom s, _ )
=> Code Word32 -> Program s s ( Code LuminaireID )
:: forall (s :: ProgramState)
. ( QuasiRandom s, _ )
=> Code Word32
-> Program s s ( Code LuminaireID )
randomLuminaire nbLuminaires = do
~( Vec4 r _ _ _ ) <- random01s
locally do
_ <- def @"i" @RW @Word32 0
_ <- def @"acc" @RW @Float 0
_ <- def @"res" @RW @LuminaireID =<< use @( Name "luminaires" :.: Name "luminaireArray" :.: AnIndex Word32 ) 0
_ <- def @"res" @RW @LuminaireID =<< use @Luminaire 0
while ( (< nbLuminaires) <<$>> get @"i" ) do
i <- get @"i"
acc <- get @"acc"
lum <- let' @( Code LuminaireID ) =<< use @( Name "luminaires" :.: Name "luminaireArray" :.: AnIndex Word32 ) i
lum <- let' =<< use @Luminaire i
acc' <- let' $ acc + view @( Name "luminaireWeight" ) lum
if acc' >= r
then do
......
......@@ -21,6 +21,8 @@ module FIR.Examples.RayTracing.Geometry
import qualified Prelude
import Data.Kind
( Type )
import Data.Proxy
( Proxy(..) )
import Data.Type.Bool
( If )
import Data.Typeable
......@@ -174,7 +176,7 @@ instance HittableGeometry Triangle where
n2 <- use @( Name "geometries" :.: Name "geometryArray" :.: AnIndex Word32 :.: Name "normal" ) i2
~( Vec2 u v ) <- use @( Name "hitAttribute" :.: Name "attributes" )
~( Vec3 px py pz ) <- let' $ p0 ^+^ u *^ ( p1 ^-^ p0 ) ^+^ v *^ ( p2 ^-^ p0 )
objectNormal <- let' $ n0 ^+^ n1 ^+^ n2 -- ( 1 - u - v ) *^ n0 ^+^ u *^ n1 ^+^ v *^ n2 --
objectNormal <- let' $ n0 ^+^ n1 ^+^ n2 -- ( 1 - u - v ) *^ n0 ^+^ u *^ n1 ^+^ v *^ n2
-- Transform back into world space.
hitPos <- let' $ ( objectToWorld !*^ Vec4 px py pz 1 )
-- Use the inverse-transpose of the object-to-world transformation to transform normal vectors.
......@@ -229,7 +231,7 @@ instance HittableGeometry Sphere where
p2 <- let' $ worldCentre ^+^ r *^ n2
t1' <- let' $ s1 * distance worldRayOrigin p1
t2' <- let' $ s2 * distance worldRayOrigin p2
assign @( Name "hitAttribute" :.: Name "attributes" ) ( Struct $ p1 :& n1 :& End )
_ <- reportIntersection t1' 0
assign @( Name "hitAttribute" :.: Name "attributes" ) ( Struct $ p2 :& n2 :& End )
......@@ -276,4 +278,4 @@ primaryClosestHitShader = Module $ entryPoint @"main" @ClosestHit do
def @"quasiRandomConstants" @R =<< use @( Name "payload" :.: Name "quasiRandomConstants" )
def @"quasiRandomState" @RW =<< use @( Name "payload" :.: Name "quasiRandomState" )
estimateRadiance accel shaderRecord hitPos normal
estimateRadiance Proxy accel shaderRecord hitPos normal
......@@ -22,6 +22,8 @@ module FIR.Examples.RayTracing.Material
-- base
import Data.Kind
( Type )
import Data.Proxy
( Proxy(..) )
import Data.Typeable
( Typeable )
import GHC.TypeNats
......@@ -283,8 +285,9 @@ instance Material Fresnel where
computeReflectance
:: forall ( i :: Nat ) ( s :: ProgramState )
. ( ( i :< 4 ) ~ True, _ )
=> Program s s ( Code Float, Code Float )
computeReflectance = do
=> Proxy i -> Program s s ( Code Float, Code Float )
-- N.B.: the Proxy argument here works around https://gitlab.haskell.org/ghc/ghc/-/issues/20921
computeReflectance _ = do
abs_cosθ_refr <- refractionCosine ( view @( Index i ) ηs ) abs_cosθ_inc
reflectance_s <-
fresnelReflectance S
......@@ -296,10 +299,10 @@ instance Material Fresnel where
( view @( Index i ) n_outs ) ( view @( Index i ) k_outs ) abs_cosθ_refr
let' $ ( abs_cosθ_refr, 0.5 * ( reflectance_s + reflectance_p ) )
( abs_cosθ_refr0, reflectance0 ) <- computeReflectance @0
( abs_cosθ_refr1, reflectance1 ) <- computeReflectance @1
( abs_cosθ_refr2, reflectance2 ) <- computeReflectance @2
( abs_cosθ_refr3, reflectance3 ) <- computeReflectance @3
( abs_cosθ_refr0, reflectance0 ) <- computeReflectance @0 Proxy
( abs_cosθ_refr1, reflectance1 ) <- computeReflectance @1 Proxy
( abs_cosθ_refr2, reflectance2 ) <- computeReflectance @2 Proxy
( abs_cosθ_refr3, reflectance3 ) <- computeReflectance @3 Proxy
reflectance <- let' $ Vec4 reflectance0 reflectance1 reflectance2 reflectance3
( vals, probs ) <-
......
......@@ -28,7 +28,7 @@ common base-common
build-depends:
base
>= 4.13 && < 4.16
>= 4.13 && < 4.17
, directory
^>= 1.3.3.0
, filepath
......@@ -36,7 +36,7 @@ common base-common
, finite-typelits
^>= 0.1.4.2
, template-haskell
>= 2.15 && < 2.18
>= 2.15 && < 2.19
, text-short
>= 0.1.4 && < 0.2
, vector
......@@ -64,7 +64,7 @@ common vulkan-common
build-depends:
bytestring
>= 0.10.9.0 && < 0.11
>= 0.10.9.0 && < 0.12
, JuicyPixels
^>= 3.3.2
, lens
......
......@@ -52,9 +52,13 @@ After extracting, we need to:
If PKG_CONFIG_PATH does not exist (`echo %PKG_CONFIG_PATH%` returns nothing), set it with `setx PKG_CONFIG_PATH path\to\sdl2\lib\pkg-config\`.
You can check that SDL2 is registered with pkg-config using `pkg-config --list-all`.
The Windows Vulkan SDK installer can be downloaded from the [LunarG website](https://vulkan.lunarg.com/sdk/home).
No further setup should be required after installing. The relevant `bin` folder (by default `VulkanSDK\[vulkan-sdk-version]\Bin`) is automatically added to PATH, and the environment variables VULKAN_SDK and VK_SDK_PATH should also have been initialised (pointing to `VulkanSDK\[vulkan-sdk-version]` by default).
The Windows Vulkan SDK installer can be downloaded from the [LunarG website](https://vulkan.lunarg.com/sdk/home). The relevant `bin` folder (by default `VulkanSDK\[vulkan-sdk-version]\Bin`) is automatically added to PATH, and the environment variables VULKAN_SDK and VK_SDK_PATH should also have been initialised (pointing to `VulkanSDK\[vulkan-sdk-version]` by default). You might need to point to the directory in your `cabal.project.local` file, e.g.
```
package vulkan
extra-lib-dirs: C:/VulkanSDK/1.2.198.1/Lib
extra-include-dirs: C:/VulkanSDK/1.2.198.1/Include/
```
<a name="linux"></a>
### Linux
......
......@@ -619,7 +619,6 @@ present queue swapchain imageIndex wait = void $ Vulkan.queuePresentKHR queue pr
, Vulkan.results = Vulkan.zero
}
getQueue :: MonadIO m => Vulkan.Device -> Int -> m Vulkan.Queue
getQueue device queueFamilyIndex = Vulkan.getDeviceQueue device ( fromIntegral queueFamilyIndex ) 0
......
......@@ -84,7 +84,7 @@ allocateMemory physicalDevice device memReqs memFlags allocateFlags = do
allocateFlagsInfo =
Vulkan.MemoryAllocateFlagsInfo
{ Vulkan.flags = allocateFlags
, Vulkan.deviceMask = 0
, Vulkan.deviceMask = 0
}
allocateInfo :: Vulkan.MemoryAllocateInfo '[ Vulkan.MemoryAllocateFlagsInfo ]
allocateInfo =
......
......@@ -324,7 +324,7 @@ createShaderBindingTableBuffer physicalDevice device ( vkPipeline -> pipeline )
( bufKeys, ( sbtBuffer, sbtPtr ) ) <-
createBufferFromPoke
( Vulkan.BUFFER_USAGE_SHADER_BINDING_TABLE_BIT_KHR
( Vulkan.BUFFER_USAGE_SHADER_BINDING_TABLE_BIT_KHR
.|. Vulkan.BUFFER_USAGE_SHADER_DEVICE_ADDRESS_BIT
)
( Vulkan.MEMORY_PROPERTY_HOST_VISIBLE_BIT .|. Vulkan.MEMORY_PROPERTY_HOST_COHERENT_BIT )
......@@ -447,7 +447,7 @@ buildAccelerationStructuresDevice physicalDevice device commandPool queue asType
buildSizes <-
Vulkan.getAccelerationStructureBuildSizesKHR device Vulkan.ACCELERATION_STRUCTURE_BUILD_TYPE_HOST_KHR
( buildGeometryInfo Vulkan.zero Vulkan.zero ) maxPrimsVector
-- We've got the sizes: now create the required buffers.
logDebug "Allocating acceleration structure buffers."
( accelKeys, ( accelBuffer, _ ) )
......
......@@ -96,9 +96,9 @@ common common
build-depends:
base
>= 4.13 && < 4.16
>= 4.13 && < 4.17
, bytestring
>= 0.10.9.0 && < 0.11
>= 0.10.9.0 && < 0.12
, directory
^>= 1.3.3.0
......@@ -125,7 +125,7 @@ library
-- modules required for testing
-- (temporarily included here)
, test
exposed-modules:
FIR
, FIR.Syntax.DebugPrintf
......@@ -169,7 +169,7 @@ library
, Data.Type.Map
, Data.Type.Maybe
, Data.Type.Nat
, Data.Type.Ord
, Data.Type.POrd
, Data.Type.Snoc
, Data.Type.String
, Deriving.Base
......@@ -242,7 +242,7 @@ library
, SPIRV.Synchronisation
, SPIRV.Version
build-depends:
build-depends:
atomic-file-ops
^>= 0.3.0.0
, binary
......@@ -262,7 +262,7 @@ library
, half
^>= 0.3
, haskus-utils-variant
^>= 3.0
>= 3.0 && < 3.3
, lens
>= 4.18 && < 5.1
, mtl
......@@ -270,7 +270,7 @@ library
, split
>= 0.2.3.3 && < 0.3
, template-haskell
>= 2.15 && < 2.18
>= 2.15 && < 2.19
, text-short
>= 0.1.4 && < 0.2
, transformers
......
......@@ -297,11 +297,12 @@ data ProductComponents (iss :: [[Type]]) (s :: k) (as :: [Type]) where
-- | Run-time index (kind-correct).
type AnIndex (ix :: Type ) = (RTOptic_ :: Optic '[ix] s a)
type AnIndex (ix :: Type ) = RTOptic_ @'[ix]
-- | Compile-time index (kind-correct).
type Index (i :: Nat ) = (Field_ i :: Optic '[] s a)
type Index (i :: Nat ) = Field_ @Nat @'[] i
-- | Compile-time field name (kind-correct).
type Name (k :: Symbol) = (Field_ k :: Optic '[] s a)
type Name (k :: Symbol) = Field_ @Symbol @'[] k
-- | Optic for components of a particular type (kind-correct).
type OfType (ty :: Type) = (OfType_ ty :: Optic '[] s ty)
......@@ -919,15 +920,14 @@ passGetterIndex (SSameSucc ( same1 :: SSameLength t_js t_as ) ) js views =
case same2 of
( sameSucc@(SSameSucc (same3 :: SSameLength t_is jss) ) ) ->
case sameSucc of
( _ :: SSameLength (i ': t_is) (js ': jss) ) ->
case ( unsafeCoerce Refl :: ZipCons t_is (Tail iss) :~: jss
, unsafeCoerce Refl :: ( t_js ': MapTail jss ) :~: iss
, unsafeCoerce Refl :: i :~: j
) of
( Refl, Refl, Refl ) ->
ConsViewer same3 (Proxy @t_is) (Proxy @(Tail iss)) Proxy
( getter k )
( passGetterIndex @t_js @(MapTail jss) @s @t_as same1 ks getters )
( _ :: SSameLength (i ': t_is) (js ': jss) )
| Refl <- ( unsafeCoerce Refl :: ZipCons t_is (Tail iss) :~: jss )
, Refl <- ( unsafeCoerce Refl :: ( t_js ': MapTail jss ) :~: iss )
, Refl <- ( unsafeCoerce Refl :: i :~: j )
, Proxy :: Proxy bss <- Proxy @(Tail iss)
-> ConsViewer same3 (Proxy @t_is) (Proxy @bss) Proxy
( getter k )
( passGetterIndex @t_js @(MapTail jss) @s @t_as same1 ks getters )
passSetterIndex
:: forall (js :: [Type]) (jss :: [[Type]]) (s :: Type) (as :: [Type])
......@@ -939,15 +939,14 @@ passSetterIndex (SSameSucc ( same1 :: SSameLength t_js t_as ) ) js sets =
case same2 of
( sameSucc@(SSameSucc (same3 :: SSameLength t_is jss) ) ) ->
case sameSucc of
( _ :: SSameLength (i ': t_is) (js ': jss) ) ->
case ( unsafeCoerce Refl :: ZipCons t_is (Tail iss) :~: jss
, unsafeCoerce Refl :: ( t_js ': MapTail jss ) :~: iss
, unsafeCoerce Refl :: i :~: j
) of
( Refl, Refl, Refl ) ->
ConsSetter same3 (Proxy @t_is) (Proxy @(Tail iss)) Proxy
( setter k )
( passSetterIndex @t_js @(MapTail jss) @s @t_as same1 ks setts )
( _ :: SSameLength (i ': t_is) (js ': jss) )
| Refl <- ( unsafeCoerce Refl :: ZipCons t_is (Tail iss) :~: jss )
, Refl <- ( unsafeCoerce Refl :: ( t_js ': MapTail jss ) :~: iss )
, Refl <- ( unsafeCoerce Refl :: i :~: j )
, Proxy :: Proxy bss <- Proxy @(Tail iss)
-> ConsSetter same3 (Proxy @t_is) (Proxy @(Tail iss)) Proxy
( setter k )
( passSetterIndex @t_js @bss @s @t_as same1 ks setts )
data Viewers (iss :: [[Type]]) (s :: Type) (as :: [Type]) where
NilViewer :: Viewers iss s '[] -- iss should always be a list of empty lists
......
......@@ -20,7 +20,7 @@ infix 4 `LazyEq`
-- Alternative version of 'Data.Type.Equality.=='.
-- Ensures that @a == a@ reduces to True for any argument @a@.
--
--
-- See "Data.Type.Equality.==", which explains the trade-off.
type family (a :: k) `LazyEq` (b :: k) :: Bool where
a `LazyEq` a = 'True
......
......@@ -14,17 +14,15 @@ Simple type-level maps (association lists).
module Data.Type.Map where
-- base
-- base
import Data.Type.Bool
( If )
import Data.Type.Ord
( Compare )
import GHC.TypeLits
( TypeError, ErrorMessage(..) )
-- fir
import Data.Type.Ord
( POrd((:<)) )
import Data.Type.POrd
( POrd(Compare, (:<)) )
------------------------------------------------
-- barebones type-level map functionality
......@@ -121,7 +119,7 @@ type family Delete (s :: k) (is :: Map k v) :: Map k v where
type family Remove (i :: Map k v) (j :: Map k v) :: Map k v where
Remove '[] j = j
Remove ( (k ':-> _) ': i) j = Remove i (Delete k j)
Remove ( (k ':-> _) ': i) j = Remove i (Delete k j)
type family InsertionSort (i :: [k :-> v]) :: Map k v where
InsertionSort '[] = '[]
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
Module: Data.Type.Ord
Module: Data.Type.POrd
Promotion of the 'Ord' type class.
-}
module Data.Type.Ord where
module Data.Type.POrd where
-- base
import Data.Type.Bool
......
......@@ -105,7 +105,7 @@ module FIR
, module Data.Product
, module Data.Type.List
, (Data.Type.Map.:->)((:->))
, module Data.Type.Ord
, module Data.Type.POrd
, AST, FIR.AST.Code, EGADT
, module FIR.AST.Type
, pattern (:$), pattern Lit, pattern Struct, pattern Array
......@@ -323,7 +323,7 @@ import Data.Product
import Data.Type.Known
import Data.Type.List
import Data.Type.Map
import Data.Type.Ord
import Data.Type.POrd
import FIR.AST
import FIR.AST.Type
import FIR.Binding
......
......@@ -67,7 +67,6 @@ import Haskus.Utils.EGADT
import Data.Tree.View
( showTree )
-- fir
import FIR.AST.ControlFlow
import FIR.AST.Display
......@@ -122,7 +121,8 @@ instance Syntactic (AST a) where
instance (SyntacticVal a, Syntactic b) => Syntactic (a -> b) where
type Internal (a -> b) = Internal a :--> Internal b
toAST f = Lam ( toAST . f . fromAST )
toAST f = Lam @( Val (InternalType a) :--> Internal b )
( toAST . f . fromAST )
fromAST (Lam f) a = fromAST ( f $ toAST a )
fromAST f a = fromAST ( f :$ toAST a )
......
{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}
{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
......@@ -32,7 +32,7 @@ import Data.Tree
-- haskus-utils-variant
import Haskus.Utils.EGADT
( pattern VF )
( EGADT, type (:<!), pattern VF )
-- fir
import Control.Arrow.Strength
......@@ -48,6 +48,9 @@ import FIR.Validation.CFG
------------------------------------------------------------
pattern If :: forall a fs
. ( GHC.Stack.HasCallStack, PrimTy a, SelectionF :<! fs )
=> EGADT fs ( Val Bool :--> Val a :--> Val a :--> Val a )
pattern If = VF IfF
pattern IfM = VF IfMF
pattern Switch s d cs = VF (SwitchF s d cs)
......
{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}
{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
......
{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}
{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment