... | ... | @@ -19,80 +19,25 @@ Besides the indirection and the resulting complications of the ping-pong style, |
|
|
|
|
|
For example, here is a simple [ TTG](https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/TreesThatGrowGuidance) representation of lambda expressions in the ping-pong style.
|
|
|
|
|
|
```wiki
|
|
|
{-# LANGUAGE TypeFamilies
|
|
|
, ConstraintKinds
|
|
|
#-}
|
|
|
module Original where
|
|
|
|
|
|
import GHC.Exts(Constraint)
|
|
|
import Data.Void
|
|
|
|
|
|
-- ...
|
|
|
|
|
|
data RdrName
|
|
|
-- = the definition of RdrName
|
|
|
|
|
|
data SrcSpan
|
|
|
-- = the definition of SrcSpan
|
|
|
|
|
|
data Located a = L SrcSpan a
|
|
|
|
|
|
-- ----------------------------------------------
|
|
|
-- TTG Base AST
|
|
|
-- ----------------------------------------------
|
|
|
type LExp x = Located (Exp x)
|
|
|
|
|
|
data Exp x
|
|
|
= Var (XVar x) (XId x)
|
|
|
| Lam (XLam x) (XId x) (LExp x)
|
|
|
| App (XApp x) (LExp x) (LExp x)
|
|
|
| Par (XPar x) (LExp x)
|
|
|
| New (XNew x)
|
|
|
|
|
|
type family XVar x
|
|
|
type family XLam x
|
|
|
type family XApp x
|
|
|
type family XPar x
|
|
|
type family XNew x
|
|
|
|
|
|
type family XId x
|
|
|
|
|
|
type ForallX (p :: * -> Constraint) x
|
|
|
= ( p (XVar x)
|
|
|
, p (XLam x)
|
|
|
, p (XApp x)
|
|
|
, p (XPar x)
|
|
|
, p (XNew x)
|
|
|
)
|
|
|
|
|
|
-- ----------------------------------------------
|
|
|
-- AST Ps (parsing phase)
|
|
|
-- ----------------------------------------------
|
|
|
|
|
|
data Ps
|
|
|
|
|
|
type ExpPs = Exp Ps
|
|
|
type LExpPs = LExp Ps
|
|
|
|
|
|
type instance XVar Ps = ()
|
|
|
type instance XLam Ps = ()
|
|
|
type instance XApp Ps = ()
|
|
|
type instance XPar Ps = ()
|
|
|
type instance XNew Ps = Void
|
|
|
|
|
|
type instance XId Ps = RdrName
|
|
|
```
|
|
|
{-# OPTIONS_GHC -Wall
|
|
|
-fno-warn-unticked-promoted-constructors
|
|
|
#-}{-# LANGUAGE TypeFamilies
|
|
|
, DataKinds
|
|
|
#-}moduleOriginalwhereimportData.VoiddataRdrName-- = the definition of RdrNamedataName-- = the definition of NamedataId-- = the definition of IddataSrcSpan-- = the definition of SrcSpandataType-- = the definition of SrcSpandataUnboundVar-- = the definition of UnboundVarnoLoc::SrcSpannoLoc= undefined -- or be an empty SrcSpan-- ------------------------------------------------ AST Base-- ----------------------------------------------dataLocated a =LSrcSpan a
|
|
|
|
|
|
typeLExp x =Located(Exp x)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)typefamilyXVar x
|
|
|
typefamilyXAbs x
|
|
|
typefamilyXApp x
|
|
|
typefamilyXPar x
|
|
|
typefamilyXNew x
|
|
|
|
|
|
-- ----------------------------------------------
|
|
|
-- Example Function (e.g., in pretty printing)
|
|
|
-- ----------------------------------------------
|
|
|
typefamilyXId x
|
|
|
|
|
|
par :: LExp Ps -> LExp Ps
|
|
|
par l@(L sp m) = L sp (Par () l)
|
|
|
-- ------------------------------------------------ GHC-Specific Decorations-- ----------------------------------------------dataPhase=Ps|Rn|TcdataGHC(p ::Phase)typeinstanceXVar(GHC_)=()typeinstanceXAbs(GHC_)=()typeinstanceXApp(GHCPs)=()typeinstanceXApp(GHCRn)=()typeinstanceXApp(GHCTc)=TypetypeinstanceXPar(GHC_)=()typeinstanceXNew(GHCPs)=VoidtypeinstanceXNew(GHCRn)=UnboundVartypeinstanceXNew(GHCTc)=UnboundVartypeinstanceXId(GHCPs)=RdrNametypeinstanceXId(GHCRn)=NametypeinstanceXId(GHCTc)=IdtypeExpPs=Exp(GHCPs)typeExpRn=Exp(GHCRn)typeExpTc=Exp(GHCTc)typeLExpPs=LExp(GHCPs)typeLExpRn=LExp(GHCRn)typeLExpTc=LExp(GHCTc)-- ------------------------------------------------ Example Function-- ----------------------------------------------par::LExp(GHC x)->LExp(GHC x)par l@(L sp (App{}))=L sp (Par() l)par l = l
|
|
|
```
|
|
|
|
|
|
**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?
|
|
|
|
|
|
## Solutions
|
|
|
|
|
|
|
... | ... | @@ -100,62 +45,55 @@ The key solution is to move source locations to the extension points, remove the |
|
|
There are a couple of ways to implement such a solution:
|
|
|
|
|
|
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?
|
|
|
|
|
|
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).
|
|
|
|
|
|
> **SLPJ** It's more than just convenience; it's much more elegant than passing these huge dictionaries. Show the code; something like
|
|
|
>
|
|
|
> ```wiki
|
|
|
> type instance XVar (Ghc p) = Located (XVarGhc p)
|
|
|
> type family XVarGhc p where
|
|
|
> XVarGhc Ps = ()
|
|
|
> XVarGhc Rn = ...
|
|
|
> XVarGhc Tc = ..
|
|
|
> ```
|
|
|
> 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
|
|
|
>
|
|
|
> ```wiki
|
|
|
> getLoc :: Located x -> SrcSpan -- As now
|
|
|
>
|
|
|
> rnExpr (Var exts id) = setSrcSpan (getLoc exts) $
|
|
|
> do { ... }
|
|
|
> ```
|
|
|
> getLoc::Located x ->SrcSpan-- As nowrnExpr(Var exts id)= setSrcSpan (getLoc exts)$do{...}
|
|
|
> ```
|
|
|
>
|
|
|
>
|
|
|
> ...etc...
|
|
|
|
|
|
|
|
|
...etc...
|
|
|
|
|
|
1. We can extend (using TTG) each datatype to add a wrapper constructor like the current `Located`.
|
|
|
1. We can extend (using TTG) each datatype to add a wrapper \*constructor\*, similar in spirit to the current `Located`.
|
|
|
|
|
|
1. The API Annotations are similar to the `SrcSpan`, in that they are additional decorations, and also currently appear wherever there is a `SrcSpan`.
|
|
|
|
|
|
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 can perhaps deal with these by either defining an additional pass, so
|
|
|
>
|
|
|
> We can perhaps deal with these by either defining an additional pass, so
|
|
|
|
|
|
```
|
|
|
dataPass=Parsed|Renamed|Typechecked|Generatedderiving(Data)
|
|
|
```
|
|
|
|
|
|
|
|
|
or by making the extra information status dependent on an additional parameter, so
|
|
|
>
|
|
|
> or by making the extra information status dependent on an additional parameter, so
|
|
|
|
|
|
```
|
|
|
dataGhcPass(l ::Location)(c ::Pass)derivinginstanceEq(GhcPass c)derivinginstance(Typeable l,Typeable c)=>Data(GhcPass l c)dataPass=Parsed|Renamed|Typecheckedderiving(Data)dataLocation=Located|UnLocated
|
|
|
```
|
|
|
|
|
|
|
|
|
Thanks to Zubin Duggal for bringing the unlocated problem up on IRC.
|
|
|
|
|
|
>
|
|
|
> Thanks to Zubin Duggal for bringing the unlocated problem up on IRC.
|
|
|
|
|
|
1. TODO (add your suggestions)
|
|
|
|
|
|
### Example (Solution A)
|
|
|
### Solution A - Example Code
|
|
|
|
|
|
|
|
|
In the code below, as compared to the one above, we have the following key changes:
|
|
|
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 `()`)
|
... | ... | @@ -163,24 +101,26 @@ In the code below, as compared to the one above, we have the following key chang |
|
|
- a pattern synonym for `L` is introduced using the typeclass
|
|
|
|
|
|
```
|
|
|
{-# LANGUAGE TypeFamilies
|
|
|
{-# OPTIONS_GHC -Wall
|
|
|
-fno-warn-unticked-promoted-constructors
|
|
|
#-}{-# LANGUAGE TypeFamilies
|
|
|
, DataKinds
|
|
|
, ConstraintKinds
|
|
|
, FlexibleInstances
|
|
|
, FlexibleContexts
|
|
|
, UndecidableInstances
|
|
|
, PatternSynonyms
|
|
|
, ViewPatterns
|
|
|
#-}moduleNewwhereimportGHC.Exts(Constraint)importData.Void-- ...dataRdrName-- = the definition of RdrNamedataSrcSpan-- = the definition of SrcSpan-- ------------------------------------------------ TTG Base AST-- ----------------------------------------------dataExp x
|
|
|
=Var(XVar x)(XId x)|Lam(XLam x)(XId x)(Exp x)|App(XApp x)(Exp x)(Exp x)|Par(XPar x)(Exp x)|New(XNew x)typefamilyXVar x
|
|
|
typefamilyXLam x
|
|
|
#-}moduleSolutionAwhereimportGHC.Exts(Constraint)importData.VoiddataRdrName-- = the definition of RdrNamedataName-- = the definition of NamedataId-- = the definition of IddataSrcSpan-- = the definition of SrcSpandataType-- = the definition of SrcSpandataUnboundVar-- = the definition of UnboundVarnoLoc::SrcSpannoLoc= undefined -- or be an empty SrcSpan-- ------------------------------------------------ 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)typefamilyXVar x
|
|
|
typefamilyXAbs x
|
|
|
typefamilyXApp x
|
|
|
typefamilyXPar x
|
|
|
typefamilyXNew x
|
|
|
|
|
|
typefamilyXId x
|
|
|
|
|
|
typeForallX(p ::*->Constraint) x
|
|
|
=( p (XVar x), p (XLam x), p (XApp x), p (XPar x), p (XNew x))-- ------------------------------------------------ AST Ps-- ----------------------------------------------dataPstypeExpPs=ExpPstypeinstanceXVarPs=SrcSpantypeinstanceXLamPs=SrcSpantypeinstanceXAppPs=SrcSpantypeinstanceXParPs=SrcSpantypeinstanceXNewPs=VoidtypeinstanceXIdPs=RdrName-- ------------------------------------------------ HasSpan Typeclass-- ----------------------------------------------classHasSpan a where
|
|
|
-- ------------------------------------------------ GHC-Specific Decorations-- ----------------------------------------------dataPhase=Ps|Rn|TcdataGHC(p ::Phase)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
|
|
|
getSpan :: a ->SrcSpan
|
|
|
setSpan :: a ->SrcSpan-> a
|
|
|
|
... | ... | @@ -192,32 +132,108 @@ instanceHasSpanVoidwhere |
|
|
getSpan x = absurd x
|
|
|
setSpan x _= absurd x
|
|
|
|
|
|
instanceForallXHasSpan x =>HasSpan(Exp x)where
|
|
|
typeForallX(p ::*->Constraint) x
|
|
|
=( p (XVar x), p (XAbs x), p (XApp x), p (XPar x), p (XNew x))instanceForallXHasSpan x =>HasSpan(Exp x)where
|
|
|
getSpan (Var ex _)= getSpan ex
|
|
|
getSpan (Lam ex __)= getSpan ex
|
|
|
getSpan (Abs ex __)= getSpan ex
|
|
|
getSpan (App ex __)= getSpan ex
|
|
|
getSpan (Par ex _)= getSpan ex
|
|
|
getSpan (New ex)= getSpan ex
|
|
|
|
|
|
setSpan (Var ex x) sp =Var(setSpan ex sp) x
|
|
|
setSpan (Lam ex x n) sp =Lam(setSpan ex sp) x n
|
|
|
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
|
|
|
|
|
|
-- ------------------------------------------------ Example Function-- ----------------------------------------------par::ExpPs->ExpPspar l@(L sp m)=Par sp l
|
|
|
-- or,-- = L sp (Par noLoc l)
|
|
|
-- ------------------------------------------------ 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
|
|
|
```
|
|
|
|
|
|
### Include API Annotations, Solution D
|
|
|
### Solution B - Example Code
|
|
|
|
|
|
|
|
|
The API Annotations can be accommodated via a straightforward extension of the type class approach, by defining
|
|
|
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` paired 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
|
|
|
|
|
|
```
|
|
|
dataExtra=ExtraSrcSpan[(SrcSpan,AnnKeywordId)]classHasExtra a where
|
|
|
{-# OPTIONS_GHC -Wall
|
|
|
-fno-warn-unticked-promoted-constructors
|
|
|
#-}{-# LANGUAGE TypeFamilies
|
|
|
, ConstraintKinds
|
|
|
, ViewPatterns
|
|
|
, PatternSynonyms
|
|
|
, DataKinds
|
|
|
, FlexibleInstances
|
|
|
#-}moduleSolutionBwhereimportData.VoiddataRdrName-- = the definition of RdrNamedataName-- = the definition of NamedataId-- = the definition of IddataSrcSpan-- = the definition of SrcSpandataType-- = the definition of SrcSpandataUnboundVar-- = the definition of UnboundVarnoLoc::SrcSpannoLoc= undefined -- or be an empty SrcSpan-- ------------------------------------------------ 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)typefamilyXVar x
|
|
|
typefamilyXAbs x
|
|
|
typefamilyXApp x
|
|
|
typefamilyXPar x
|
|
|
typefamilyXNew x
|
|
|
|
|
|
typefamilyXId x
|
|
|
|
|
|
-- ------------------------------------------------ GHC-Specific Decorations-- ----------------------------------------------dataPhase=Ps|Rn|TcdataGHC(p ::Phase)typeinstanceXVar(GHC p)=(SrcSpan,XVarGHC p)typeinstanceXAbs(GHC p)=(SrcSpan,XAbsGHC p)typeinstanceXApp(GHC p)=(SrcSpan,XAppGHC p)typeinstanceXPar(GHC p)=(SrcSpan,XParGHC p)typeinstanceXNew(GHC p)=(SrcSpan,XNewGHC p)typeinstanceXId(GHC p)=XIdGHC p
|
|
|
|
|
|
|
|
|
typefamilyXVarGHC(p ::Phase)whereXVarGHC_=()typefamilyXAbsGHC(p ::Phase)whereXAbsGHC_=()typefamilyXAppGHC(p ::Phase)whereXAppGHCPs=()XAppGHCRn=()XAppGHCTc=TypetypefamilyXParGHC(p ::Phase)whereXParGHC_=()typefamilyXNewGHC(p ::Phase)whereXNewGHCPs=VoidXNewGHC_=UnboundVartypefamilyXIdGHC(p ::Phase)whereXIdGHCPs=RdrNameXIdGHCRn=NameXIdGHCTc=IdtypeExpPs=Exp(GHCPs)typeExpRn=Exp(GHCRn)typeExpTc=Exp(GHCTc)-- ------------------------------------------------ getter/setter of Span-- (similar to methods of HasSpan)-- ----------------------------------------------classHasSpan a where
|
|
|
getSpan :: a ->SrcSpan
|
|
|
setSpan :: a ->SrcSpan-> a
|
|
|
|
|
|
getApiAnns :: a ->[(SrcSpan,AnnKeywordId)]
|
|
|
setApiAnns :: a ->[(SrcSpan,AnnKeywordId)]-> 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
|
|
|
|
|
|
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)patternL::HasSpan a =>SrcSpan-> a -> a
|
|
|
patternL s m <-(getSpan' ->(s , m))whereL s m = setSpan m s
|
|
|
|
|
|
-- ------------------------------------------------ Example Function-- ----------------------------------------------par::Exp(GHC p)->Exp(GHC p)par l@(L sp (App{}))=L sp (Par(noLoc,()) l)par l = l
|
|
|
```
|
|
|
|
|
|
### Solution C - Example Code
|
|
|
|
|
|
|
|
|
In the code below, as compared to the original one 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
|
|
|
|
|
|
```
|
|
|
{-# OPTIONS_GHC -Wall
|
|
|
-fno-warn-unticked-promoted-constructors
|
|
|
#-}{-# LANGUAGE TypeFamilies
|
|
|
, DataKinds
|
|
|
, ConstraintKinds
|
|
|
, PatternSynonyms
|
|
|
#-}moduleSolutionCwhereimportData.VoiddataRdrName-- = the definition of RdrNamedataName-- = the definition of NamedataId-- = the definition of IddataSrcSpan-- = the definition of SrcSpandataType-- = the definition of SrcSpandataUnboundVar-- = the definition of UnboundVarnoLoc::SrcSpannoLoc= undefined -- or be an empty SrcSpan-- ------------------------------------------------ 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)typefamilyXVar x
|
|
|
typefamilyXAbs x
|
|
|
typefamilyXApp x
|
|
|
typefamilyXPar x
|
|
|
typefamilyXNew x
|
|
|
|
|
|
typefamilyXId x
|
|
|
|
|
|
-- ------------------------------------------------ GHC-Specific Decorations-- ----------------------------------------------dataPhase=Ps|Rn|TcdataGHC(p ::Phase)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
|
|
|
``` |
|
|
\ No newline at end of file |