Skip to content

Instantly share code, notes, and snippets.

@conklech

conklech/TestInline.hs

Last active December 30, 2015 07:29
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save conklech/7796570 to your computer and use it in GitHub Desktop.
Save conklech/7796570 to your computer and use it in GitHub Desktop.
Download ZIP
Demonstration of unrolled vinyl lenses
Raw
TestInline.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
module TestInline (modified, modified_field2, with_field2, get_field2, get_nolens) where
import Data.Vinyl
import Data.Functor.Identity
-- compile with
-- cabal build --ghc-option=-ddump-simpl --ghc-option=-dsuppress-all --ghc-option=-O2
type Field1 = "Field1" ::: String
field1 :: Field1
field1 = Field
type Field2 = "Field2" ::: String
field2 :: Field2
field2 = Field
-- Using `(<+>)` prevents full optimization
original :: PlainRec '[Field1, Field2]
original = (Identity "test1" :& Identity "test2" :& RNil)
-- interestingly, GHC doesn't pre-compose the string when adding only one character.
modified :: PlainRec '[Field1, Field2]
modified = rMod field2 (++ "modified") original
modified_field2 = rGet field2 modified
with_field2 :: String -> PlainRec '[Field1, Field2]
with_field2 s = rPut field2 s modified
get_field2, get_nolens :: PlainRec '[Field1, Field2] -> String
get_field2 = rGet field2
get_nolens (_ :& Identity s :& _) = s
Raw
with-patch.hs
-- build with -O2
Result size of Tidy Core = {terms: 73, types: 353, coercions: 115}
get_nolens1
get_nolens1 = patError "TestInline.hs:34:1-37|function get_nolens"
get_nolens
get_nolens =
\ ds_d2HK ->
case ds_d2HK
of _ { :& @ t_a2FY @ rs_a2FZ @ sy_a2G0 rb_d2Ip ds1_d2HL ds2_d2HM ->
case ds2_d2HM of _ {
RNil ipv_s2IB -> get_nolens1;
:& @ t1_a2G2 @ rs1_a2G3 @ sy1_a2G4 rb1_d2In ds3_d2HV ds4_d2HW ->
ds3_d2HV `cast` ...
}
}
cast'_$d<:
cast'_$d<: = $f<:RecRec0 (($WSubsetNil) `cast` ...)
get_field2
get_field2 =
\ x1_X1b9 ->
case x1_X1b9
of _
{ :& @ t1_a111 @ rs1_a112 @ sy1_a113 rb1_d19f x2_a109 xs_a10a ->
case xs_a10a `cast` ...
of _ { :& @ t2_a10M @ rs_a10N @ sy2_a10O rb2_d18Q x_a103 _ ->
x_a103 `cast` ...
}
}
modified2
modified2 = unpackCString# "test1"
modified_field2
modified_field2 = unpackCString# "test2modified"
modified1
modified1 =
:&
@~ <(':) * ("Field2" ::: [Char]) ('[] *)>
(modified_field2 `cast` ...)
($WRNil)
modified
modified =
:&
@~ <(':) * ("Field1" ::: String) ((':) * Field2 ('[] *))>
(modified2 `cast` ...)
modified1
with_field2
with_field2 =
\ s_a2FT ->
:&
@~ <(':) * ("Field1" ::: String) ((':) * Field2 ('[] *))>
(modified2 `cast` ...)
(:&
@~ <(':) * ("Field2" ::: [Char]) ('[] *)>
(s_a2FT `cast` ...)
($WRNil))
cast'
cast' =
\ w4_s2sV ->
$w$ccast
@~ <"Field1" ::: String> (($WHere) `cast` ...) cast'_$d<: w4_s2sV
Raw
without-patch.hs
Result size of Tidy Core
= {terms: 357, types: 1,247, coercions: 422}
get_nolens1
get_nolens1 = patError "TestInline.hs:34:1-37|function get_nolens"
get_nolens
get_nolens =
\ ds_d9kM ->
case ds_d9kM
of _ { :& @ t_a9j0 @ rs_a9j1 @ sy_a9j2 rb_d9lr ds1_d9kN ds2_d9kO ->
case ds2_d9kO of _ {
RNil ipv_s9lD -> get_nolens1;
:& @ t1_a9j4 @ rs1_a9j5 @ sy1_a9j6 rb1_d9lp ds3_d9kX ds4_d9kY ->
ds3_d9kX `cast` ...
}
}
get_field3
get_field3 =
There
@~ <(':) * ("Field1" ::: String) ((':) * Field2 ('[] *))> ($WHere)
get_field2_a2
get_field2_a2 = \ tpl_X13 -> tpl_X13
poly_a_r9FN
poly_a_r9FN =
\ @ rr_t1L ->
patError "Data\\Vinyl\\Lens.hs:(53,9)-(62,59)|function go"
poly_a1_r9FO
poly_a1_r9FO =
\ @ rr_t1S ->
patError "Data\\Vinyl\\Lens.hs:(66,9)-(67,55)|function go'"
Rec {
get_field2_go'
get_field2_go' =
\ @ rr_t1S ds_d1gV ds1_d1gW ->
case ds_d1gV of _ {
Here @ xs_a10Y rb_d1mS ->
case ds1_d1gW of _ {
RNil ipv_s1B7 -> poly_a1_r9FO;
:& @ t1_a110 @ rs1_a111 @ sy1_a112 rb1_d1mV x1_a10i xs_a10j ->
x1_a10i `cast` ...
};
There @ xs_a11c @ y_a11d rb_d1nk p_a10k ->
case ds1_d1gW of _ {
RNil ipv_s1Bn -> poly_a1_r9FO;
:& @ t1_a11f @ rs1_a11g @ sy1_a11h rb1_d1nm x1_a10l xs_a10m ->
(get_field2_go p_a10k (xs_a10m `cast` ...)) `cast` ...
}
}
get_field2_go
get_field2_go =
\ @ rr_t1L eta_B2 eta1_Xv ->
case eta_B2 of _ {
Here @ xs_a11r rb_d1nG ->
case eta1_Xv of _ {
RNil ipv_s1BR -> poly_a_r9FN;
:& @ t1_a11t @ rs1_a11u @ sy1_a11v rb1_d1nJ x1_aZO xs_aZP ->
x1_aZO `cast` ...
};
There @ xs_a11D @ y_a11E rb_d1o8 ds_d1hR ->
case ds_d1hR of _ {
Here @ xs1_a11G rb1_d1oa ->
case eta1_Xv of _ {
RNil ipv_s1C9 -> poly_a_r9FN;
:& @ t1_a11I @ rs1_a11J @ sy1_a11K rb2_d1od a3_aZQ ds1_d1lm ->
case ds1_d1lm of _ {
RNil ipv_s1Cd -> poly_a_r9FN;
:& @ t2_a11M @ rs2_a11N @ sy2_a11O rb3_d1ol x1_aZR xs_aZS ->
x1_aZR `cast` ...
}
};
There @ xs1_a124 @ y1_a125 rb1_d1oS ds1_d1hS ->
case ds1_d1hS of _ {
Here @ xs2_a127 rb2_d1oU ->
case eta1_Xv of _ {
RNil ipv_s1Cz -> poly_a_r9FN;
:& @ t1_a129 @ rs1_a12a @ sy1_a12b rb3_d1oX a3_aZT ds2_d1kG ->
case ds2_d1kG of _ {
RNil ipv_s1CD -> poly_a_r9FN;
:& @ t2_a12d @ rs2_a12e @ sy2_a12f rb4_d1p6 b_aZU ds3_d1kM ->
case ds3_d1kM of _ {
RNil ipv_s1CJ -> poly_a_r9FN;
:& @ t3_a12h @ rs3_a12i @ sy3_a12j rb5_d1pd x1_aZV xs_aZW ->
x1_aZV `cast` ...
}
}
};
There @ xs2_a12B @ y2_a12C rb2_d1pS ds2_d1hT ->
case ds2_d1hT of _ {
Here @ xs3_a12E rb3_d1pU ->
case eta1_Xv of _ {
RNil ipv_s1D7 -> poly_a_r9FN;
:& @ t1_a12G @ rs1_a12H @ sy1_a12I rb4_d1pX a3_aZY ds3_d1jO ->
case ds3_d1jO of _ {
RNil ipv_s1Db -> poly_a_r9FN;
:& @ t2_a12K @ rs2_a12L @ sy2_a12M rb5_d1q7 b_aZZ ds4_d1jU ->
case ds4_d1jU of _ {
RNil ipv_s1Dh -> poly_a_r9FN;
:& @ t3_a12O @ rs3_a12P @ sy3_a12Q rb6_d1qe c_a100 ds5_d1k0 ->
case ds5_d1k0 of _ {
RNil ipv_s1Dn -> poly_a_r9FN;
:& @ t4_a12S @ rs4_a12T @ sy4_a12U rb7_d1ql x1_a101 xs_a102 ->
x1_a101 `cast` ...
}
}
}
};
There @ xs3_a13h @ y3_a13i rb3_d1r8 ds3_d1hU ->
let {
$wfail1_s9BC
$wfail1_s9BC =
case eta1_Xv of _ {
RNil ipv_s1DL -> (poly_a_r9FN) `cast` ...;
:& @ t1_a146 @ rs1_a147 @ sy1_a148 rb4_d1ra a3_a10c ds5_d1iZ ->
case ds5_d1iZ of _ {
RNil ipv_s1DQ -> (poly_a_r9FN) `cast` ...;
:& @ t2_a14a @ rs2_a14b @ sy2_a14c rb5_d1rk b_a10d ds6_d1j5 ->
case ds6_d1j5 of _ {
RNil ipv_s1DV -> (poly_a_r9FN) `cast` ...;
:& @ t3_a14e @ rs3_a14f @ sy3_a14g rb6_d1rr c_a10e ds7_d1jb ->
case ds7_d1jb of _ {
RNil ipv_s1E0 -> (poly_a_r9FN) `cast` ...;
:& @ t4_a14i @ rs4_a14j @ sy4_a14k rb7_d1ry d_a10f xs_a10g ->
(get_field2_go' ds3_d1hU (xs_a10g `cast` ...)) `cast` ...
}
}
}
} } in
case ds3_d1hU of _ {
Here @ xs4_a13k rb4_d1sg ->
case eta1_Xv of _ {
RNil ipv_s1E7 -> $wfail1_s9BC `cast` ...;
:& @ t1_a13m @ rs1_a13n @ sy1_a13o rb5_d1sj a3_a104 ds4_d1hW ->
case ds4_d1hW of _ {
RNil ipv_s1Eb -> $wfail1_s9BC `cast` ...;
:& @ t2_a13q @ rs2_a13r @ sy2_a13s rb6_d1su b_a105 ds5_d1i2 ->
case ds5_d1i2 of _ {
RNil ipv_s1Eh -> $wfail1_s9BC `cast` ...;
:& @ t3_a13u @ rs3_a13v @ sy3_a13w rb7_d1sB c_a106 ds6_d1i8 ->
case ds6_d1i8 of _ {
RNil ipv_s1En -> $wfail1_s9BC `cast` ...;
:& @ t4_a13y @ rs4_a13z @ sy4_a13A rb8_d1sI d_a107 ds7_d1ie ->
case ds7_d1ie of _ {
RNil ipv_s1Et -> $wfail1_s9BC `cast` ...;
:& @ t5_a13C
@ rs5_a13D
@ sy5_a13E
rb9_d1sP
x1_a108
xs_a109 ->
x1_a108 `cast` ...
}
}
}
}
};
There @ ipv0_s1ES @ ipv1_s1ET ipv_s1EU ipv1_s1EV ->
$wfail1_s9BC `cast` ...
}
}
}
}
}
end Rec }
get_field1
get_field1 = \ x1_X1vH -> get_field2_go get_field3 x1_X1vH
get_field2
get_field2 = get_field1 `cast` ...
modified2
modified2 = unpackCString# "test1"
modified_field1
modified_field1 = unpackCString# "modified"
modified_field2
modified_field2 = unpackAppendCString# "test2" modified_field1
modified1
modified1 =
:&
@~ <(':) * ("Field2" ::: String) ('[] *)>
(modified_field2 `cast` ...)
($WRNil)
modified
modified =
:&
@~ <(':)
* ("Field1" ::: String) ((':) * ("Field2" ::: String) ('[] *))>
(modified2 `cast` ...)
modified1
with_field2
with_field2 =
\ s_a9iV ->
:&
@~ <(':)
* ("Field1" ::: String) ((':) * ("Field2" ::: String) ('[] *))>
(modified2 `cast` ...)
(:&
@~ <(':) * ("Field2" ::: String) ('[] *)>
(s_a9iV `cast` ...)
($WRNil))
cast'
cast' =
\ w4_s8Ry ->
:&
@~ <(':) * ("Field1" ::: String) ('[] *)>
(($f<:RecRec1 ($WHere) w4_s8Ry) `cast` ...)
($WRNil)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment