Due to a large amount of spam we do not allow new users to create repositories, they are "external" users. If you are a new user and want to create a repository, for example for forking GHC, open a new issue on ghc/ghc using the "get-verified" issue template
@@ -18,34 +18,31 @@ Besides the indirection and the resulting complications of the ping-pong style,
The key solution is to move source locations to the extension points, remove the indirection (e.g., the wrapper datatype `LExp`) altogether, and update the related code (e.g., functions over `Exp`) accordingly.
We assume that open extension typefamily instances for GHC-specific decorations are nested, such that they call a closed typefamily to choose the extension based on the index (e.g., see `XApp` calling `XAppGHC` in the code below).
There are a couple of ways to implement such a solution:
1. We can nest extension typefamilies to be able to say that all constructors have the same uniform decorations (e.g., `SrcSpan`) beside their specific ones. This is just for convenience as `ForallX*` constraint quantifications can simulate the same (see the code for solution A).
1. We put the source locations in the new field extensions and use a typeclass to set/get the locations.
1. We put the source locations in the new constructor extension, similar in spirit to the current `Located`.
> **SLPJ** It's more than just convenience; it's much more elegant than passing these huge dictionaries. Show the code; something like
>
> ```
> typeinstanceXVar(Ghc p)=Located(XVarGhc p)typefamilyXVarGhc p whereXVarGhcPs=()XVarGhcRn=...XVarGhcTc=..
> ```
>
>
> It's quite nice that we get a *closed* type family for the GHC extensions. Now a typical function might look like
>
> ```
> getLoc::Located x ->SrcSpan-- As nowrnExpr(Var exts id)= setSrcSpan (getLoc exts)$do{...}
> ```
>
>
> ...etc...
1. Using a typeclass to set/get source locations
**SLPJ**: Explain `ForallX`. I hate it because it implies that we'll pass massive dictionaries around; and what happens if we have lots of different data types, not just one?
Notes:
- The API Annotations are similar to the `SrcSpan`, in that they are additional decorations, and also currently appear wherever there is a `SrcSpan`.
The API Annotations can be accommodated via a straightforward extension of the type class approach, by defining
1. We can extend (using TTG) each datatype to add a wrapper \*constructor\*, similar in spirit to the current `Located`.
```
dataExtra=ExtraSrcSpan[(SrcSpan,AnnKeywordId)]classHasExtra a where
getSpan :: a ->SrcSpan
setSpan :: a ->SrcSpan-> a
1. The API Annotations are similar to the `SrcSpan`, in that they are additional decorations, and also currently appear wherever there is a `SrcSpan`.
getApiAnns :: a ->[(SrcSpan,AnnKeywordId)]
setApiAnns :: a ->[(SrcSpan,AnnKeywordId)]-> a
```
1. We also currently have sections of AST without source locations, such as those generated when converting TH AST to hsSyn AST, or for GHC derived code.
- We also currently have sections of AST without source locations, such as those generated when converting TH AST to hsSyn AST, or for GHC derived code.
>
> We can perhaps deal with these by either defining an additional pass, so
> Thanks to Zubin Duggal for bringing the unlocated problem up on IRC.
1. TODO (add your suggestions)
- The setter/getter functions can be generalised to set/get anything:
```
classHas b a where
get :: a -> b
set :: a -> b -> a
```
## An example to illustrate
...
...
@@ -73,20 +76,27 @@ To explain the design choices, we use a simple language of expressions.
Here are the base definitions in [TTG style](implementing-trees-that-grow/trees-that-grow-guidance):
```
{-# OPTIONS_GHC -Wall -fno-warn-unticked-promoted-constructors #-}{-# LANGUAGE TypeFamilies, DataKinds #-}-- ------------------------------------------------ AST Base-- ----------------------------------------------dataExp x
=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 constructortypefamilyXVar x
{-# OPTIONS_GHC -Wall #-}{-# LANGUAGE TypeFamilies #-}moduleTTGwhere-- ------------------------------------------------ AST Base-- ----------------------------------------------dataExp x
=Var(XVar x)(XId x)|Abs(XAbs x)(XId x)(Exp x)|App(XApp x)(Exp x)(Exp x)|Par(XPar x)(Exp x)|New(XNew x)-- The extension constructortypefamilyXVar x
typefamilyXAbs x
typefamilyXApp x
typefamilyXPar x
typefamilyXNew x
typefamilyXId x
```
-- ------------------------------------------------ GHC-Specific Delarations-- ----------------------------------------------dataPhase=Ps|Rn|TcdataGHC(p ::Phase)dataRdrName=-- the definition of RdrNamedataName=-- the definition of NamedataId=-- the definition of IddataSrcSpan=-- the definition of SrcSpandataType=-- the definition of TypedataUnboundVar=-- the definition of UnboundVardataLocated a =LSrcSpan a
with some basic GHC-specific types defined as
noLoc::SrcSpannoLoc=...typeinstanceXId(GHC p)=XIdGHC p
```
{-# OPTIONS_GHC -Wall -fno-warn-unticked-promoted-constructors #-}{-# LANGUAGE TypeFamilies , DataKinds #-}moduleBasicGHCTypeswhereimportData.Void-- ------------------------------------------------ GHC-Specific Declarations-- ----------------------------------------------dataPhase=Ps|Rn|TcdataGHC(p ::Phase)dataRdrName-- = the definition of RdrNamedataName-- = the definition of NamedataId-- = the definition of IddataSrcSpan-- = the definition of SrcSpandataType-- = the definition of SrcSpandataUnboundVar-- = the definition of UnboundVardataLocated a =LSrcSpan a
noLoc::SrcSpannoLoc= undefined -- or be an empty SrcSpantypefamilyXAppGHC(p ::Phase)whereXAppGHCPs=()XAppGHCRn=()XAppGHCTc=TypetypefamilyXNewGHC(p ::Phase)whereXNewGHCPs=VoidXNewGHC_=UnboundVartypefamilyXIdGHC(p ::Phase)whereXIdGHCPs=RdrNameXIdGHCRn=NameXIdGHCTc=Id
```
...
...
@@ -99,101 +109,39 @@ family.
Here is a representation of lambda expressions in the ping-pong style.
Ufortunately, this forces us to redefine the base TTG data type,
forcing it into ping-pong style, which is why we don't like it.
```wiki
type LExp x = Located (Exp x)
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.
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)
-- ----------------------------------------------
-- GHC-Specific Decorations
-- ----------------------------------------------
type instance XVar (GHC _) = ()
type instance XAbs (GHC _) = ()
type instance XApp (GHC Ps) = ()
type instance XApp (GHC Rn) = ()
type instance XApp (GHC Tc) = Type
type instance XPar (GHC _) = ()
type instance XNew (GHC Ps) = Void
type instance XNew (GHC Rn) = UnboundVar
type instance XNew (GHC Tc) = UnboundVar
```
{-# OPTIONS_GHC -Wall #-}{-# LANGUAGE TypeFamilies #-}moduleOriginalwhereimportBasicGHCTypes-- ------------------------------------------------ AST Base-- ----------------------------------------------typeLExp x =Located(Exp x)dataExp 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 constructortypefamilyXVar x
typefamilyXAbs x
typefamilyXApp x
typefamilyXPar x
typefamilyXNew x
typefamilyXId x
typeinstance XId (GHC Ps) = RdrName
typeinstance XId (GHC Rn) = Name
typeinstanceXId(GHC Tc) = Id
-- ------------------------------------------------ GHC-Specific Decorations-- ----------------------------------------------typeinstanceXVar(GHC_)=()typeinstanceXAbs(GHC_)=()typeinstanceXApp(GHC p)=XAppGHC p
typeinstanceXPar(GHC_)=()typeinstanceXNew(GHC p)=XNewGHC p
typeinstanceXId(GHC p)=XIdGHC p
-- ----------------------------------------------
-- Example Function
-- ----------------------------------------------
par :: LExp (GHC x) -> LExp (GHC x)
par l@(L sp (App{})) = L sp (Par () l)
par l = l
-- ------------------------------------------------ Example Function-- ----------------------------------------------par::LExp(GHC x)->LExp(GHC x)par l@(L sp (App{}))=L sp (Par() l)par l = l
```
### Solution A - Example Code
In the code below, as compared to the original one above, we have the following key changes:
In the code below, as compared to the ping-pong style above, we have the following key changes:
-`LExp` is replaced with `Exp`
- field extensions are set to have a `SrcSpan` paired (via `Located`)
with a closed type family specialised for GHC phases
- a setter/getter function pair is introduced
- a pattern synonym for `L` is introduced using the setter/getter function
```
-- ------------------------------------------------ GHC-Specific Decorations-- ----------------------------------------------typeinstanceXVar(GHC p)=Located()typeinstanceXAbs(GHC p)=Located()typeinstanceXApp(GHC p)=Located(XAppGHC p)typeinstanceXPar(GHC p)=Located()typeinstanceXNew(GHC p)=Located(XNewGHC p)-- NB: if GHC later wants to add extension fields to (say)-- XAbs, we can just redefine XAbs (GHC p) to be more like-- the XApp casetypefamilyXAppGHC(p ::Phase)whereXAppGHCPs=()XAppGHCRn=()XAppGHCTc=TypetypefamilyXNewGHC(p ::Phase)whereXNewGHCPs=VoidXNewGHC_=UnboundVar-- ------------------------------------------------ getter/setter of Span-- (similar to methods of HasSpan)-- ----------------------------------------------classHasSpan a where
getSpan :: a ->SrcSpan
setSpan :: a ->SrcSpan-> a
instanceHasSpanSrcSpanwhere
getSpan = id
setSpan _= id
instanceHasSpanVoidwhere
getSpan x = absurd x
setSpan x _= absurd x
instanceHasSpan(Exp(GHC p))where
getSpan (Var ex _)= fst ex
getSpan (Abs ex __)= fst ex
getSpan (App ex __)= fst ex
getSpan (Par ex _)= fst ex
getSpan (New ex)= fst ex
- a setter/getter function pair is introduced by a typeclass
- a pattern synonym `LL` is introduced using the setter/getter function pair
setSpan (Var ex x) sp =Var(setFst ex sp) x
setSpan (Abs ex x n) sp =Abs(setFst ex sp) x n
setSpan (App ex l m) sp =App(setFst ex sp) l m
setSpan (Par ex m) sp =Par(setFst ex sp) m
setSpan (New ex) sp =New(setFst ex sp)setFst::(a , b)-> a ->(a , b)setFst(_, b) a' =(a' , b)getSpan'::HasSpan a => a ->(SrcSpan, a)getSpan' m =(getSpan m , m)patternLL::HasSpan a =>SrcSpan-> a -> a
patternLL s m <-(getSpan' ->(s , m))whereLL s m = setSpan m s
-- ------------------------------------------------ Example Function-- ----------------------------------------------par::Exp(GHC p)->Exp(GHC p)par l@(LL sp (App{}))=LL sp (Par(noLoc,()) l)par l = l
In the code below, as compared to the original one above, we have the following key changes:
-`LExp` is replaced with `Exp`
- field extensions are set to have a `SrcSpan` (instead of `()`)
- a setter/getter typeclass `HasSpan` (and instances) is introduced
- a pattern synonym for `L` is introduced using the typeclass
```
-- ------------------------------------------------ GHC-Specific Decorations-- ----------------------------------------------typeinstanceXVar(GHC_)=SrcSpantypeinstanceXAbs(GHC_)=SrcSpantypeinstanceXApp(GHCPs)=SrcSpantypeinstanceXApp(GHCRn)=SrcSpantypeinstanceXApp(GHCTc)=(SrcSpan,Type)typeinstanceXPar(GHC_)=SrcSpantypeinstanceXNew(GHCPs)=VoidtypeinstanceXNew(GHCRn)=(SrcSpan,UnboundVar)typeinstanceXNew(GHCTc)=(SrcSpan,UnboundVar)typeinstanceXId(GHCPs)=RdrNametypeinstanceXId(GHCRn)=NametypeinstanceXId(GHCTc)=IdtypeExpPs=Exp(GHCPs)typeExpRn=Exp(GHCRn)typeExpTc=Exp(GHCTc)-- ------------------------------------------------ HasSpan Typeclass and L Pattern Synonym-- ----------------------------------------------classHasSpan a where
-- NB: if GHC later wants to add extension fields to (say)-- XAbs, we can just redefine XAbs (GHC p) to be more like-- the XApp case-- ------------------------------------------------ HasSpan Typeclass and LL Pattern Synonym-- ----------------------------------------------classHasSpan a where
getSpan :: a ->SrcSpan
setSpan :: a ->SrcSpan-> a
...
...
@@ -205,8 +153,17 @@ instanceHasSpanVoidwhere
getSpan x = absurd x
setSpan x _= absurd x
instanceHasSpan(Located a)where
getSpan = getLoc
setSpan = setLoc
instanceHasSpan(Exp(GHC p))where{- or,
type ForallX (p :: * -> Constraint) x
=( p (XVar x), p (XAbs x), p (XApp x), p (XPar x), p (XNew x))instanceForallXHasSpan x =>HasSpan(Exp x)where
= ( p (XVar x) , p (XAbs x) , p (XApp x) , p (XPar x)
, p (XNew x) )
instance ForallX HasSpan x => HasSpan (Exp x) where
-}
getSpan (Var ex _)= getSpan ex
getSpan (Abs ex __)= getSpan ex
getSpan (App ex __)= getSpan ex
...
...
@@ -217,21 +174,27 @@ typeForallX(p ::*->Constraint) x
setSpan (Abs ex x n) sp =Abs(setSpan ex sp) x n
setSpan (App ex l m) sp =App(setSpan ex sp) l m
setSpan (Par ex m) sp =Par(setSpan ex sp) m
setSpan (New ex) sp =New(setSpan ex sp)getSpan'::HasSpan a => a ->(SrcSpan, a)getSpan' m =(getSpan m , m)patternL::HasSpan a =>SrcSpan-> a -> a
patternL s m <-(getSpan' ->(s , m))whereL s m = setSpan m s
setSpan (New ex) sp =New(setSpan ex sp)getSpan'::HasSpan a => a ->Located a
getSpan' m =L(getSpan m) m
-- ------------------------------------------------ Example Function-- ----------------------------------------------par::ForallXHasSpan(GHC p)=>Exp(GHC p)->Exp(GHC p)par l@(L sp (App{}))=L sp (Par noLoc l)par l = l
patternLL::HasSpan a =>SrcSpan-> a -> a
patternLL s m <-(getSpan' ->L s m)whereLL s m = setSpan m s
-- ------------------------------------------------ Example Function-- ----------------------------------------------par::Exp(GHC p)->Exp(GHC p)par l@(LL sp (App{}))=LL sp (Par(L noLoc ()) l)par l = l
```
### Solution C - Example Code
### Solution B - Example Code
In the code below, as compared to the original one above, we have the following key changes:
In the code below, as compared to the ping-pong style above, we have the following key changes:
-`LExp` is replaced with `Exp`
- a new constructor extension is introduced to wrap `ExpPs` with a `SrcSpan`
- a pattern synonym for `L` is introduced
- a new constructor extension is introduced to wrap `Exp` with a `SrcSpan`
- a pattern synonym `LL` is introduced using the new constructor
```
-- ------------------------------------------------ GHC-Specific Decorations-- ----------------------------------------------typeinstanceXVar(GHC_)=()typeinstanceXAbs(GHC_)=()typeinstanceXApp(GHCPs)=()typeinstanceXApp(GHCRn)=()typeinstanceXApp(GHCTc)=TypetypeinstanceXPar(GHC_)=()typeinstanceXNew(GHC p)=Either(SrcSpan,Exp(GHC p))(XNewGHC p)typefamilyXNewGHC(p ::Phase)whereXNewGHCPs=VoidXNewGHCRn=UnboundVarXNewGHCTc=UnboundVartypeinstanceXId(GHCPs)=RdrNametypeinstanceXId(GHCRn)=NametypeinstanceXId(GHCTc)=IdtypeExpPs=Exp(GHCPs)typeExpRn=Exp(GHCRn)typeExpTc=Exp(GHCTc)-- ------------------------------------------------ L Pattern Synonym-- ----------------------------------------------patternL::SrcSpan->Exp(GHC p)->Exp(GHC p)patternL sp m =New(Left(sp , m))-- ------------------------------------------------ Example Function-- ----------------------------------------------par::Exp(GHC p)->Exp(GHC p)par l@(L sp (App{}))=L sp (Par() l)par l = l
{-# OPTIONS_GHC -Wall #-}{-# LANGUAGE TypeFamilies, PatternSynonyms #-}moduleSolutionBwhereimportBasicGHCTypesimportTTG-- ------------------------------------------------ GHC-Specific Decorations-- ----------------------------------------------typeinstanceXVar(GHC_)=()typeinstanceXAbs(GHC_)=()typeinstanceXApp(GHC p)=XAppGHC p
typeinstanceXPar(GHC_)=()typeinstanceXNew(GHC p)=Either(Located(Exp(GHC p)))(XNewGHC p)typeinstanceXId(GHC p)=XIdGHC p
-- NB: if GHC later wants to add extension fields to (say)-- XAbs, we can just redefine XAbs (GHC p) to be more like-- the XApp case-- ------------------------------------------------ LL Pattern Synonym-- ----------------------------------------------patternLL::SrcSpan->Exp(GHC p)->Exp(GHC p)patternLL sp m =New(Left(L sp m))-- ------------------------------------------------ Example Function-- ----------------------------------------------par::Exp(GHC p)->Exp(GHC p)par l@(LL sp (App{}))=LL sp (Par() l)par l = l
