Changes

Sebastian Graf · 6c9fc37e
--- a/implementing-trees-that-grow/handling-source-locations.md
+++ b/implementing-trees-that-grow/handling-source-locations.md
@@ -238,7 +238,8 @@ Pros:

 Cons:

- Potential trouble with inference of type family arguments. The type family has to be injective, which can be guaranteed in practice
+- Potential trouble with inference of type family arguments. The `WrapL` type family has to be injective, which can be guaranteed in practice
+- 

 ## An example to illustrate

@@ -284,6 +285,8 @@ module BasicGHCTypes where
 data Phase = Ps | Rn | Tc
 data GHC (p :: Phase)

+data TH
+
 data NoExt = NoExt
 data NoNewCon

@@ -301,7 +304,7 @@ data SrcSpan    -- = the definition of SrcSpan
 data Located a = L SrcSpan a

 noSrcSpan :: SrcSpan
-noSrcSpan = ... -- an empty SrcSpan
+noSrcSpan = undefined -- an empty SrcSpan

 type family   XAppGHC (p :: Phase)
 type instance XAppGHC Ps = NoExt
@@ -333,7 +336,7 @@ family.


 Here is a representation of lambda expressions in the ping-pong style.
-Unfortunately, this forces us to redefine the base TTG data type,
+Unfortunately, this forces us to redefine the base TTG data type for e.g. TH,
 forcing it into ping-pong style, which is why we don't like it for the reasons mentioned above.


@@ -375,69 +378,17 @@ type instance XNew (GHC p)  = XNewGHC p
 type instance XId  (GHC p)  = XIdGHC  p

 -- ----------------------------------------------
-- Example Function
-- ----------------------------------------------
-par :: LExp (GHC x) -> LExp (GHC x)
-par l@(L sp (App{})) = L sp (Par NoExt l)
-par l                = l
-```
-
-### Ping-pong style revamped (solution D)
-
-Here's an example for solution D:
-
-### Ping-pong style
-
-
-Here is a representation of lambda expressions in the ping-pong style.
-Unfortunately, this forces us to redefine the base TTG data type,
-forcing it into ping-pong style, which is why we don't like it for the reasons mentioned above.
-
-
-```
-{-# OPTIONS_GHC -Wall -fno-warn-unticked-promoted-constructors #-}
-{-# LANGUAGE TypeFamilies, DataKinds #-}
-
-module Original where
-
-import BasicGHCTypes
-
-- | Only wraps a `Located` around `f` when `p` is a `GhcPass`.
-type family WrapL p (f :: * -> *) = r | r -> p f where
-  WrapL (GhcPass p) f       = Located (f (GhcPass p))
-  -- This bogus instance is unfortunate, but needed for injectivity and thus
-  -- type inference.
-  WrapL p           Located = Located (Located p)
-  WrapL p           f       =          f p
-
-- ----------------------------------------------
-- AST Base
+-- TH-Specific Decorations
 -- ----------------------------------------------
-type LExp x = WrapL x Exp
-
-data Exp x -- Notice the alternation between LExp and Exp
-  = Var (XVar x) (XId x)
-  | Abs (XAbs x) (XId x)  (LExp x)
-  | App (XApp x) (LExp x) (LExp x)
-  | Par (XPar x) (LExp x)
-  | New (XNew x) -- The extension constructor
-
-type family XVar x
-type family XAbs x
-type family XApp x
-type family XPar x
-type family XNew x
-type family XId  x
+type instance WrapL TH f = f TH

-- ----------------------------------------------
-- GHC-Specific Decorations
-- ----------------------------------------------
-type instance XVar (GHC _)  = NoExt
-type instance XAbs (GHC _)  = NoExt
-type instance XApp (GHC p)  = XAppGHC p
-type instance XPar (GHC _)  = NoExt
-type instance XNew (GHC p)  = XNewGHC p
-type instance XId  (GHC p)  = XIdGHC  p
+-- Or whatever the instances for TH are
+type instance XVar TH = NoExt
+type instance XAbs TH = NoExt
+type instance XApp TH = NoExt
+type instance XPar TH = NoExt
+type instance XNew TH = NoExt
+type instance XId  TH = NoExt

 -- ----------------------------------------------
 -- Example Function
@@ -445,6 +396,13 @@ type instance XId  (GHC p)  = XIdGHC  p
 par :: LExp (GHC x) -> LExp (GHC x)
 par l@(L sp (App{})) = L sp (Par NoExt l)
 par l                = l
+
+-- ----------------------------------------------
+-- Example Function in TH
+-- ----------------------------------------------
+parTH :: LExp TH -> LExp TH
+parTH l@(L sp (App{})) = L sp (Par NoExt l)  -- Yikes! TH doesn't care for SrcLocs...
+parTH l                = l
 ```

 ### The SrcSpan Accessor Typeclass
@@ -622,6 +580,85 @@ par l@(LL sp (App{})) = Par (L sp NoExt) l
 par l                 = l
 ```

+### Solution D - Example Code
+
+
+In the code below, as compared to the old ping-pong style, we have the following key changes:
+
+- `LExp` becomes `WrapL x Exp` and reduces to `Located (Exp x)` for `x ~ GHC p` and to `Exp x` for `x ~ TH`
+- That's it
+
+```
+{-# OPTIONS_GHC -Wall -fno-warn-unticked-promoted-constructors #-}
+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies, DataKinds #-}
+
+module SolutionD where
+
+import BasicGHCTypes
+
+-- | We use this to only wrap a `Located` around `f` when `p` is `GHC`.
+-- Injectivity is important for inference.
+type family WrapL p (f :: * -> *) = r | r -> p f
+
+-- ----------------------------------------------
+-- AST Base
+-- ----------------------------------------------
+type LExp x = WrapL x Exp
+
+data Exp x -- Notice the alternation between LExp and Exp
+  = Var (XVar x) (XId x)
+  | Abs (XAbs x) (XId x)  (LExp x)
+  | App (XApp x) (LExp x) (LExp x)
+  | Par (XPar x) (LExp x)
+  | New (XNew x) -- The extension constructor
+
+type family XVar x
+type family XAbs x
+type family XApp x
+type family XPar x
+type family XNew x
+type family XId  x
+
+-- ----------------------------------------------
+-- GHC-Specific Decorations
+-- ----------------------------------------------
+type instance WrapL (GHC p) f = Located (f (GHC p))
+
+type instance XVar (GHC _)  = NoExt
+type instance XAbs (GHC _)  = NoExt
+type instance XApp (GHC p)  = XAppGHC p
+type instance XPar (GHC _)  = NoExt
+type instance XNew (GHC p)  = XNewGHC p
+type instance XId  (GHC p)  = XIdGHC  p
+
+-- ----------------------------------------------
+-- TH-Specific Decorations
+-- ----------------------------------------------
+type instance WrapL TH f = f TH
+
+-- Or whatever the instances for TH are
+type instance XVar TH = NoExt
+type instance XAbs TH = NoExt
+type instance XApp TH = NoExt
+type instance XPar TH = NoExt
+type instance XNew TH = NoExt
+type instance XId  TH = NoExt
+
+-- ----------------------------------------------
+-- Example Function
+-- ----------------------------------------------
+par :: LExp (GHC x) -> LExp (GHC x)
+par l@(L sp (App{})) = L sp (Par NoExt l)
+par l                = l
+
+-- ----------------------------------------------
+-- Example Function in TH
+-- ----------------------------------------------
+parTH :: LExp TH -> LExp TH
+parTH l@App{} = Par NoExt l -- Nice!
+parTH l       = l
+```
+
 ## Implementation Details

 ### General Plan