Skip to content

Instantly share code, notes, and snippets.

@mikeplus64

mikeplus64/generated Core

Last active August 29, 2015 14:23
Show Gist options
  • Save mikeplus64/87301cc7e26321f322e6 to your computer and use it in GitHub Desktop.
Save mikeplus64/87301cc7e26321f322e6 to your computer and use it in GitHub Desktop.
Download ZIP
the magical dissappearing GHC.Generics
Raw
generated Core
[1 of 1] Compiling Main ( test.hs, test.o )
==================== Simplified expression ====================
quoteExp stmt (unpackCString# "SELECT 123"#)
==================== Tidy Core ====================
Result size of Tidy Core
= {terms: 663, types: 1,112, coercions: 349}
$fSelectorAsdf4 :: [Char]
$fSelectorAsdf4 = unpackCString# "foobar"#
$fSelectorAsdf5 :: [Char]
$fSelectorAsdf5 = unpackCString# "barfoo"#
$fSelectorAsdf6 :: [Char]
$fSelectorAsdf6 = unpackCString# "asdfhth"#
$fSelectorAsdf7 :: [Char]
$fSelectorAsdf7 = unpackCString# "asdfhth1"#
$fSelectorAsdf8 :: [Char]
$fSelectorAsdf8 = unpackCString# "asdfhth2"#
aoid :: Word32
aoid = W32# (__word 25)
aoid1 :: Word32
aoid1 = W32# (__word 20)
aoid2 :: Word32
aoid2 = W32# (__word 701)
$fConstructorAsdf1 :: [Char]
$fConstructorAsdf1 = unpackCString# "Asdf"#
$fDatatypeAsdf1 :: [Char]
$fDatatypeAsdf1 = unpackCString# "Main"#
$fDatatypeAsdf_$s$dmisNewtype
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t D1Asdf f a -> Bool
$fDatatypeAsdf_$s$dmisNewtype =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a3) _ ->
False
$fConstructorAsdf_$s$dmconFixity
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t C1_0Asdf f a -> Fixity
$fConstructorAsdf_$s$dmconFixity =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a3) _ ->
Prefix
lvl3 :: Text
lvl3 = unpackCString# "NULL input"#
asdfhth2 :: Asdf -> Text
asdfhth2 =
\ (ds :: Asdf) -> case ds of _ { Asdf ds1 ds2 ds3 ds4 ds5 -> ds5 }
asdfhth1 :: Asdf -> Text
asdfhth1 =
\ (ds :: Asdf) -> case ds of _ { Asdf ds1 ds2 ds3 ds4 ds5 -> ds4 }
asdfhth :: Asdf -> Text
asdfhth =
\ (ds :: Asdf) -> case ds of _ { Asdf ds1 ds2 ds3 ds4 ds5 -> ds3 }
barfoo :: Asdf -> Double
barfoo =
\ (ds :: Asdf) -> case ds of _ { Asdf ds1 ds2 ds3 ds4 ds5 -> ds2 }
foobar :: Asdf -> Int
foobar =
\ (ds :: Asdf) -> case ds of _ { Asdf ds1 ds2 ds3 ds4 ds5 -> ds1 }
lvl20 :: Int
lvl20 = I# 5
lvl21 :: Either Text Asdf
lvl21 = Left lvl3
$w$cfromFields :: Int# -> Int# -> Array# Field -> Either Text Asdf
$w$cfromFields =
\ (ww :: Int#) (ww1 :: Int#) (ww2 :: Array# Field) ->
case ww1 of wild {
__DEFAULT -> Left (fromFieldsWrongLength lvl20 (I# wild));
5 ->
case indexArray# ww2 ww of _ { (# ipv #) ->
case ipv of wild1 {
Field dt dt1 dt2 dt3 dt4 dt5 ->
case dt of _ {
__DEFAULT -> Left (fromFieldsTypeMismatch aoid1 wild1);
__word 20 ->
case indexArray# ww2 (+# ww 1) of _ { (# ipv1 #) ->
case ipv1 of wild3 {
Field dt6 dt7 dt8 dt9 dt10 dt11 ->
case dt6 of _ {
__DEFAULT -> Left (fromFieldsTypeMismatch aoid2 wild3);
__word 701 ->
case indexArray# ww2 (+# ww 2) of _ { (# ipv2 #) ->
case ipv2 of wild5 {
Field dt12 dt13 dt14 dt15 dt16 dt17 ->
case dt12 of _ {
__DEFAULT -> Left (fromFieldsTypeMismatch aoid wild5);
__word 25 ->
case text (PS dt14 dt15 dt16 dt17) of _ {
Left e -> Left e;
Right r ->
case indexArray# ww2 (+# ww 3) of _ { (# ipv3 #) ->
case ipv3 of wild8 {
Field dt18 dt19 dt20 dt21 dt22 dt23 ->
case dt18 of _ {
__DEFAULT -> Left (fromFieldsTypeMismatch aoid wild8);
__word 25 ->
case text (PS dt20 dt21 dt22 dt23) of _ {
Left e -> Left e;
Right r1 ->
case indexArray# ww2 (+# ww 4) of _ { (# ipv4 #) ->
case ipv4 of wild11 {
Field dt24 dt25 dt26 dt27 dt28 dt29 ->
case dt24 of _ {
__DEFAULT ->
Left (fromFieldsTypeMismatch aoid wild11);
__word 25 ->
case text (PS dt26 dt27 dt28 dt29) of _ {
Left e -> Left e;
Right r2 ->
Right
(Asdf
(case $wa
0
(plusAddr# dt2 dt4)
(plusAddr#
dt2 (+# dt4 dt5))
realWorld#
of _ { (# ipv5, ipv6 #) ->
case touch# dt3 ipv5
of _ { __DEFAULT ->
ipv6
}
})
(case $wa2
(__word 0)
(plusAddr# dt8 dt10)
(plusAddr#
dt8 (+# dt10 dt11))
realWorld#
of _ { (# ipv5, ipv6 #) ->
case touch# dt9 ipv5
of _ { __DEFAULT ->
ipv6 `cast` ...
}
})
r
r1
r2)
}
};
NULL dt24 ->
case dt24 of _ {
__DEFAULT ->
Left (fromFieldsTypeMismatch aoid wild11);
__word 25 -> lvl21
}
}
}
}
};
NULL dt18 ->
case dt18 of _ {
__DEFAULT -> Left (fromFieldsTypeMismatch aoid wild8);
__word 25 -> lvl21
}
}
}
}
};
NULL dt12 ->
case dt12 of _ {
__DEFAULT -> Left (fromFieldsTypeMismatch aoid wild5);
__word 25 -> lvl21
}
}
}
};
NULL dt6 ->
case dt6 of _ {
__DEFAULT -> Left (fromFieldsTypeMismatch aoid2 wild3);
__word 701 -> lvl21
}
}
}
};
NULL dt ->
case dt of _ {
__DEFAULT -> Left (fromFieldsTypeMismatch aoid1 wild1);
__word 20 -> lvl21
}
}
}
}
$fViaFieldsAsdf_$cfromFields
:: Environment -> Vector Field -> Either Text Asdf
$fViaFieldsAsdf_$cfromFields =
\ _ (w1 :: Vector Field) ->
case w1 of _ { Vector ww1 ww2 ww3 -> $w$cfromFields ww1 ww2 ww3 }
$w$ctoFields
:: Int -> Double -> Text -> Text -> Text -> Vector Field
$w$ctoFields =
\ (ww :: Int)
(ww1 :: Double)
(ww2 :: Text)
(ww3 :: Text)
(ww4 :: Text) ->
runSTRep
(\ (@ s) (s1 :: State# s) ->
case newArray# 5 (uninitialised) (s1 `cast` ...)
of _ { (# ipv, ipv1 #) ->
case int8 (Left (case ww of _ { I# x# -> I64# x# }))
of _ { PS dt2 dt3 dt4 dt5 ->
case writeArray#
ipv1 0 (Field (__word 20) (narrow32Int# dt5) dt2 dt3 dt4 dt5) ipv
of s'# { __DEFAULT ->
case int8 (Right (ww1 `cast` ...)) of _ { PS dt1 dt6 dt7 dt8 ->
case writeArray#
ipv1 1 (Field (__word 701) (narrow32Int# dt8) dt1 dt6 dt7 dt8) s'#
of s'#1 { __DEFAULT ->
case text (Left ww2) of _ { PS dt9 dt10 dt11 dt12 ->
case writeArray#
ipv1
2
(Field (__word 25) (narrow32Int# dt12) dt9 dt10 dt11 dt12)
s'#1
of s'#2 { __DEFAULT ->
case text (Left ww3) of _ { PS dt13 dt14 dt15 dt16 ->
case writeArray#
ipv1
3
(Field (__word 25) (narrow32Int# dt16) dt13 dt14 dt15 dt16)
s'#2
of s'#3 { __DEFAULT ->
case text (Left ww4) of _ { PS dt17 dt18 dt19 dt20 ->
case writeArray#
ipv1
4
(Field (__word 25) (narrow32Int# dt20) dt17 dt18 dt19 dt20)
s'#3
of s'#4 { __DEFAULT ->
case unsafeFreezeArray# ipv1 s'#4 of _ { (# ipv4, ipv5 #) ->
(# ipv4 `cast` ..., Vector 0 5 ipv5 #)
}
}
}
}
}
}
}
}
}
}
}
})
$fViaFieldsAsdf_$ctoFields :: Environment -> Asdf -> Vector Field
$fViaFieldsAsdf_$ctoFields =
\ _ (w1 :: Asdf) ->
case w1 of _ { Asdf ww1 ww2 ww3 ww4 ww5 ->
$w$ctoFields ww1 ww2 ww3 ww4 ww5
}
$fViaFieldsAsdf :: ViaFields Asdf
$fViaFieldsAsdf =
D:ViaFields $fViaFieldsAsdf_$ctoFields $fViaFieldsAsdf_$cfromFields
main5 :: ResultValue Postgres -> Either Text (Rows Asdf)
main5 = $fCxValuePostgresRows_$cdecodeValue $fViaFieldsAsdf
main4 :: ResultRow Postgres -> Either Text (Identity (Rows Asdf))
main4 =
\ (row :: ResultRow Postgres) ->
case main5
(case row of _ { Vector dt dt1 dt2 ->
case indexArray# dt2 dt of _ { (# ipv #) -> ipv }
})
of _ {
Left x -> Left x;
Right y -> Right (y `cast` ...)
}
main3
:: forall s.
State# s -> (# State# s, Vector (StmtParam Postgres) #)
main3 =
\ (@ s) (s1 :: State# s) ->
case newArray# 0 (uninitialised) (s1 `cast` ...)
of _ { (# ipv, ipv1 #) ->
case unsafeFreezeArray# ipv1 ipv of _ { (# ipv2, ipv3 #) ->
(# ipv2 `cast` ..., Vector 0 0 ipv3 #)
}
}
main2 :: Stmt Postgres
main2 =
case unpackCString# "SELECT 123"# of _ { Text dt1 dt2 dt3 ->
case runSTRep main3 of _ { Vector dt5 dt6 dt7 ->
Stmt dt1 dt2 dt3 dt5 dt6 dt7 True
}
}
main1 :: State# RealWorld -> (# State# RealWorld, () #)
main1 =
\ (eta :: State# RealWorld) ->
case singleEx1 (main4 `cast` ...) main2 of _ { __DEFAULT ->
hPutStr2 stdout shows1 True eta
}
main :: IO ()
main = main1 `cast` ...
main6 :: State# RealWorld -> (# State# RealWorld, () #)
main6 = runMainIO1 (main1 `cast` ...)
$fSelectorAsdf3_$cselName
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t S1_0_4Asdf f a -> [Char]
$fSelectorAsdf3_$cselName =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a2) _ ->
$fSelectorAsdf8
$fSelectorAsdf3 :: Selector S1_0_4Asdf
$fSelectorAsdf3 = $fSelectorAsdf3_$cselName `cast` ...
$fSelectorAsdf2_$cselName
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t S1_0_3Asdf f a -> [Char]
$fSelectorAsdf2_$cselName =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a2) _ ->
$fSelectorAsdf7
$fSelectorAsdf2 :: Selector S1_0_3Asdf
$fSelectorAsdf2 = $fSelectorAsdf2_$cselName `cast` ...
$fSelectorAsdf1_$cselName
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t S1_0_2Asdf f a -> [Char]
$fSelectorAsdf1_$cselName =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a2) _ ->
$fSelectorAsdf6
$fSelectorAsdf1 :: Selector S1_0_2Asdf
$fSelectorAsdf1 = $fSelectorAsdf1_$cselName `cast` ...
$fSelectorAsdf0_$cselName
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t S1_0_1Asdf f a -> [Char]
$fSelectorAsdf0_$cselName =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a2) _ ->
$fSelectorAsdf5
$fSelectorAsdf0 :: Selector S1_0_1Asdf
$fSelectorAsdf0 = $fSelectorAsdf0_$cselName `cast` ...
$fSelectorAsdf_$cselName
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t S1_0_0Asdf f a -> [Char]
$fSelectorAsdf_$cselName =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a2) _ ->
$fSelectorAsdf4
$fSelectorAsdf :: Selector S1_0_0Asdf
$fSelectorAsdf = $fSelectorAsdf_$cselName `cast` ...
$fConstructorAsdf_$cconIsRecord
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t C1_0Asdf f a -> Bool
$fConstructorAsdf_$cconIsRecord =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a2) _ ->
True
$fConstructorAsdf_$cconName
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t C1_0Asdf f a -> [Char]
$fConstructorAsdf_$cconName =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a2) _ ->
$fConstructorAsdf1
a :: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a3.
t C1_0Asdf f a3 -> Fixity
a =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a3) _ ->
Prefix
$fConstructorAsdf :: Constructor C1_0Asdf
$fConstructorAsdf =
D:Constructor
$fConstructorAsdf_$cconName a $fConstructorAsdf_$cconIsRecord
$fDatatypeAsdf_$cmoduleName
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t D1Asdf f a -> [Char]
$fDatatypeAsdf_$cmoduleName =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a2) _ ->
$fDatatypeAsdf1
$fDatatypeAsdf_$cdatatypeName
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a.
t D1Asdf f a -> [Char]
$fDatatypeAsdf_$cdatatypeName =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a2) _ ->
$fConstructorAsdf1
a1
:: forall (t :: * -> (* -> *) -> * -> *) (f :: * -> *) a3.
t D1Asdf f a3 -> Bool
a1 =
\ (@ (t :: * -> (* -> *) -> * -> *)) (@ (f :: * -> *)) (@ a3) _ ->
False
$fDatatypeAsdf :: Datatype D1Asdf
$fDatatypeAsdf =
D:Datatype
$fDatatypeAsdf_$cdatatypeName $fDatatypeAsdf_$cmoduleName a1
$fGenericAsdf_$cto :: forall x. Rep Asdf x -> Asdf
$fGenericAsdf_$cto =
\ (@ x) (ds :: Rep Asdf x) ->
case ds `cast` ... of _ { :*: ds1 ds2 ->
case ds1 of _ { :*: ds3 ds4 ->
case ds2 of _ { :*: ds5 ds6 ->
case ds6 of _ { :*: ds7 ds8 ->
Asdf
(ds3 `cast` ...)
(ds4 `cast` ...)
(ds5 `cast` ...)
(ds7 `cast` ...)
(ds8 `cast` ...)
}
}
}
}
$fGenericAsdf_$cfrom :: forall x. Asdf -> Rep Asdf x
$fGenericAsdf_$cfrom =
\ (@ x) (ds :: Asdf) ->
case ds of _ { Asdf g1 g2 g3 g4 g5 ->
(:*:
(:*: (g1 `cast` ...) (g2 `cast` ...))
(:*: (g3 `cast` ...) (:*: (g4 `cast` ...) (g5 `cast` ...))))
`cast` ...
}
$fGenericAsdf :: Generic Asdf
$fGenericAsdf = D:Generic $fGenericAsdf_$cfrom $fGenericAsdf_$cto
main :: IO ()
main = main6 `cast` ...
------ Local rules for imported ids --------
"SPEC/Main $dmisNewtype @ D1Asdf" [ALWAYS]
forall ($dDatatype :: Datatype D1Asdf).
$dmisNewtype $dDatatype
= $fDatatypeAsdf_$s$dmisNewtype
"SPEC/Main $dmconFixity @ C1_0Asdf" [ALWAYS]
forall ($dConstructor :: Constructor C1_0Asdf).
$dmconFixity $dConstructor
= $fConstructorAsdf_$s$dmconFixity
Linking test ...
Raw
haskell source
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
import Control.Monad.Identity
import Data.Text
import GHC.Generics
import Hasql
import Hasql.Postgres
data Asdf = Asdf
{ foobar :: Int
, barfoo :: Double
, asdfhth :: Text
, asdfhth1 :: Text
, asdfhth2 :: Text
} deriving (Generic)
instance ViaFields Asdf
foo :: Tx Postgres s (Identity (Rows Asdf))
foo = singleEx [stmt|SELECT 123|]
main :: IO ()
main = foo `seq` print ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment