haskell-tools-backend-ghc 0.4.1.1 → 0.4.1.2
raw patch · 21 files changed
+386/−429 lines, 21 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Language.Haskell.Tools.AST.FromGHC.GHCUtils: instance (Language.Haskell.Tools.AST.FromGHC.GHCUtils.GHCName n, Language.Haskell.Tools.AST.FromGHC.GHCUtils.HsHasName n) => Language.Haskell.Tools.AST.FromGHC.GHCUtils.HsHasName (HsBinds.Sig n)
- Language.Haskell.Tools.AST.FromGHC.Modules: createModuleInfo :: ModSummary -> Trf (ModuleInfo Name)
+ Language.Haskell.Tools.AST.FromGHC.GHCUtils: instance Language.Haskell.Tools.AST.FromGHC.GHCUtils.HsHasName n => Language.Haskell.Tools.AST.FromGHC.GHCUtils.HsHasName (HsBinds.Sig n)
+ Language.Haskell.Tools.AST.FromGHC.Modules: trfImportModifier :: Trf (AnnMaybeG UImportModifier (Dom r) RangeStage)
- Language.Haskell.Tools.AST.FromGHC.Modules: loadSplices :: ModSummary -> HsModule RdrName -> HsGroup Name -> Trf a -> Trf a
+ Language.Haskell.Tools.AST.FromGHC.Modules: loadSplices :: HsModule RdrName -> HsGroup Name -> Trf a -> Trf a
Files
- Language/Haskell/Tools/AST/FromGHC.hs +3/−3
- Language/Haskell/Tools/AST/FromGHC/AddTypeInfo.hs +25/−24
- Language/Haskell/Tools/AST/FromGHC/Binds.hs +29/−29
- Language/Haskell/Tools/AST/FromGHC/Binds.hs-boot +6/−9
- Language/Haskell/Tools/AST/FromGHC/Decls.hs +41/−41
- Language/Haskell/Tools/AST/FromGHC/Exprs.hs +22/−29
- Language/Haskell/Tools/AST/FromGHC/Exprs.hs-boot +5/−8
- Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs +16/−16
- Language/Haskell/Tools/AST/FromGHC/Kinds.hs +16/−19
- Language/Haskell/Tools/AST/FromGHC/Literals.hs +6/−12
- Language/Haskell/Tools/AST/FromGHC/Modules.hs +41/−77
- Language/Haskell/Tools/AST/FromGHC/Monad.hs +8/−11
- Language/Haskell/Tools/AST/FromGHC/Names.hs +13/−28
- Language/Haskell/Tools/AST/FromGHC/Patterns.hs +18/−20
- Language/Haskell/Tools/AST/FromGHC/SourceMap.hs +4/−5
- Language/Haskell/Tools/AST/FromGHC/Stmts.hs +17/−20
- Language/Haskell/Tools/AST/FromGHC/TH.hs +15/−15
- Language/Haskell/Tools/AST/FromGHC/TH.hs-boot +5/−8
- Language/Haskell/Tools/AST/FromGHC/Types.hs +18/−24
- Language/Haskell/Tools/AST/FromGHC/Utils.hs +77/−30
- haskell-tools-backend-ghc.cabal +1/−1
Language/Haskell/Tools/AST/FromGHC.hs view
@@ -4,6 +4,6 @@ module Language.Haskell.Tools.AST.FromGHC ( trfModule, trfModuleRename, addTypeInfos, runTrf ) where -import Language.Haskell.Tools.AST.FromGHC.Modules -import Language.Haskell.Tools.AST.FromGHC.Monad -import Language.Haskell.Tools.AST.FromGHC.AddTypeInfo +import Language.Haskell.Tools.AST.FromGHC.AddTypeInfo (addTypeInfos) +import Language.Haskell.Tools.AST.FromGHC.Modules (trfModule, trfModuleRename) +import Language.Haskell.Tools.AST.FromGHC.Monad (runTrf)
Language/Haskell/Tools/AST/FromGHC/AddTypeInfo.hs view
@@ -4,35 +4,34 @@ #-} module Language.Haskell.Tools.AST.FromGHC.AddTypeInfo (addTypeInfos) where +import Bag as GHC (bagToList) import GHC -import OccName as GHC hiding (varName) -import TcEvidence as GHC -import Bag as GHC -import Unique as GHC -import UniqFM as GHC import HscTypes as GHC -import Module as GHC -import TysWiredIn as GHC -import Type as GHC -import UniqSupply as GHC +import Id as GHC (Id(..), mkVanillaGlobal) +import Module as GHC (Module(..), moduleEnvElts) import Name as GHC hiding (varName) -import Var as GHC -import Id as GHC +import OccName as GHC (OccName(..), mkDataOcc) import SrcLoc as GHC +import TcEvidence as GHC (EvBind(..), TcEvBinds(..)) +import Type as GHC (Type(..), mkTyVarTy, mkTyConTy) +import TysWiredIn as GHC (starKindTyCon) +import UniqFM as GHC (eltsUFM) +import UniqSupply as GHC (uniqFromSupply, mkSplitUniqSupply) +import Var as GHC (Var(..), Id(..)) -import Data.Maybe -import Data.List as List -import qualified Data.Map as Map -import Control.Monad.IO.Class -import Control.Monad.Trans.Class +import Control.Applicative (Applicative(..), (<$>), Alternative(..)) +import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State -import Control.Applicative -import Data.Generics.Uniplate.Operations -import Data.Generics.Uniplate.Data +import Control.Monad.Trans.Class (MonadTrans(..)) +import Data.Generics.Uniplate.Data () +import Data.Generics.Uniplate.Operations (universeBi) +import Data.List as List +import qualified Data.Map as Map (fromList, lookup) +import Data.Maybe (Maybe(..), fromMaybe, catMaybes) import Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.AST.SemaInfoTypes as AST -import Language.Haskell.Tools.AST.FromGHC.GHCUtils +import Language.Haskell.Tools.AST.FromGHC.GHCUtils (getTopLevelId) +import Language.Haskell.Tools.AST.SemaInfoTypes as AST (mkCNameInfo) addTypeInfos :: LHsBinds Id -> Ann AST.UModule (Dom GHC.Name) RangeStage -> Ghc (Ann AST.UModule IdDom RangeStage) addTypeInfos bnds mod = do @@ -53,7 +52,8 @@ _ -> do (none,rest) <- gets (break ((\(RealSrcSpan sp) -> sp `containsSpan` loc) . fst)) case rest of [] -> error $ "Ambiguous or implicit name missing, at: " ++ show loc ((_,id):more) -> do put (none ++ more) - return $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) id) + return $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) id + _ -> error "addTypeInfos: Cannot access a the semantics of a name.") pure (traverse (lift . getType)) (traverse (lift . getType)) pure pure) mod) (extractSigIds bnds ++ extractSigBindIds bnds) where locMapping = Map.fromList $ map (\(L l id) -> (l, id)) $ extractExprIds bnds @@ -86,10 +86,11 @@ _ -> [] ) . concatMap universeBi . bagToList where getImplVars (EvBinds evbnds) = catMaybes $ map getEvVar $ bagToList evbnds + getImplVars _ = [] getEvVar (EvBind lhs _ False) = Just lhs getEvVar _ = Nothing extractSigBindIds :: LHsBinds Id -> [(SrcSpan,Id)] -extractSigBindIds = catMaybes . map (\case L l bs@(IPBind (Right id) _) -> Just (l,id) - _ -> Nothing +extractSigBindIds = catMaybes . map (\case L l (IPBind (Right id) _) -> Just (l,id) + _ -> Nothing ) . concatMap universeBi . bagToList
Language/Haskell/Tools/AST/FromGHC/Binds.hs view
@@ -4,35 +4,25 @@ -- | Functions that convert the value and function definitions of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.Binds where -import Control.Monad.Reader - -import SrcLoc as GHC -import RdrName as GHC +import ApiAnnotation as GHC (AnnKeywordId(..)) +import Bag as GHC (bagToList) +import BasicTypes as GHC (FixityDirection(..), Fixity(..)) import HsBinds as GHC import HsExpr as GHC -import BasicTypes as GHC -import ApiAnnotation as GHC -import Bag as GHC -import Outputable as GHC -import HsPat as GHC -import HsDecls as GHC -import HsTypes as GHC -import OccName as GHC -import Name as GHC -import BooleanFormula as GHC +import HsPat as GHC (LPat(..)) +import HsTypes as GHC (HsWildCardBndrs(..), HsImplicitBndrs(..)) +import SrcLoc as GHC import Data.List -import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST.FromGHC.Exprs -import Language.Haskell.Tools.AST.FromGHC.Patterns -import Language.Haskell.Tools.AST.FromGHC.Types -import Language.Haskell.Tools.AST.FromGHC.Kinds +import Language.Haskell.Tools.AST.FromGHC.Exprs (trfExpr) import Language.Haskell.Tools.AST.FromGHC.Monad +import Language.Haskell.Tools.AST.FromGHC.Names +import Language.Haskell.Tools.AST.FromGHC.Patterns (trfPattern) +import Language.Haskell.Tools.AST.FromGHC.Types (trfType) import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST.FromGHC.GHCUtils -import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), AnnListG(..), Dom, RangeStage) +import Language.Haskell.Tools.AST (Ann(), AnnMaybeG(), AnnListG(), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST trfBind :: TransformName n r => Located (HsBind n) -> Trf (Ann AST.UValueBind (Dom r) RangeStage) @@ -40,14 +30,14 @@ trfBind' :: TransformName n r => HsBind n -> Trf (AST.UValueBind (Dom r) RangeStage) -- a value binding (not a function) -trfBind' (FunBind { fun_id = id, fun_matches = MG { mg_alts = unLoc -> [L matchLoc (Match { m_pats = [], m_grhss = GRHSs [L rhsLoc (GRHS [] expr)] (unLoc -> locals) })]} }) +trfBind' (FunBind { fun_id = id, fun_matches = MG { mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = GRHSs [L _ (GRHS [] expr)] (L _ locals) })]} }) = AST.USimpleBind <$> copyAnnot AST.UVarPat (define $ trfName id) <*> addToScope locals (annLocNoSema (combineSrcSpans (getLoc expr) <$> tokenLoc AnnEqual) (AST.UUnguardedRhs <$> trfExpr expr)) <*> addToScope locals (trfWhereLocalBinds locals) trfBind' (FunBind id (MG (unLoc -> matches) _ _ _) _ _ _) = AST.UFunBind <$> makeNonemptyIndentedList (mapM (trfMatch (unLoc id)) matches) trfBind' (PatBind pat (GRHSs rhs (unLoc -> locals)) _ _ _) = AST.USimpleBind <$> trfPattern pat <*> trfRhss rhs <*> trfWhereLocalBinds locals -trfBind' (AbsBinds _ _ _ _ _) = error "AbsBinds are not allowed as an input to the conversion (they are generated by the type checker)" -trfBind' (PatSynBind _) = error "UPattern synonym bindings should be recognized on the declaration level" +trfBind' (PatSynBind _) = error "Pattern synonym bindings should be recognized on the declaration level" +trfBind' _ = error "Bindings generated by the compiler cannot be converted" trfMatch :: TransformName n r => n -> Located (Match n (LHsExpr n)) -> Trf (Ann AST.UMatch (Dom r) RangeStage) trfMatch id = trfLocNoSema (trfMatch' id) @@ -89,16 +79,18 @@ trfRhsGuard' (BindStmt pat body _ _ _) = AST.UGuardBind <$> trfPattern pat <*> trfExpr body trfRhsGuard' (BodyStmt body _ _ _) = AST.UGuardCheck <$> trfExpr body trfRhsGuard' (LetStmt (unLoc -> binds)) = AST.UGuardLet <$> trfLocalBinds binds +trfRhsGuard' _ = error "trfRhsGuard': not a valid guard stmt" trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybeG AST.ULocalBinds (Dom r) RangeStage) trfWhereLocalBinds EmptyLocalBinds = nothing "" "" atTheEnd trfWhereLocalBinds binds - = makeJust <$> annLocNoSema (combineSrcSpans (getBindLocs binds) <$> tokenLoc AnnWhere) (AST.ULocalBinds <$> addToScope binds (trfLocalBinds binds)) + = makeJust <$> annLocNoSema (combineSrcSpans (getBindLocs binds) <$> tokenLocBack AnnWhere) (AST.ULocalBinds <$> addToScope binds (trfLocalBinds binds)) getBindLocs :: HsLocalBinds n -> SrcSpan getBindLocs (HsValBinds (ValBindsIn binds sigs)) = foldLocs $ map getLoc (bagToList binds) ++ map getLoc sigs getBindLocs (HsValBinds (ValBindsOut binds sigs)) = foldLocs $ map getLoc (concatMap (bagToList . snd) binds) ++ map getLoc sigs getBindLocs (HsIPBinds (IPBinds binds _)) = foldLocs $ map getLoc binds +getBindLocs EmptyLocalBinds = noSrcSpan trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnListG AST.ULocalBind (Dom r) RangeStage) trfLocalBinds (HsValBinds (ValBindsIn binds sigs)) @@ -111,17 +103,24 @@ <*> mapM trfLocalSig sigs)) trfLocalBinds (HsIPBinds (IPBinds binds _)) = makeIndentedListBefore " " (after AnnWhere) (mapM trfIpBind binds) +trfLocalBinds EmptyLocalBinds + -- TODO: implement + = error "trfLocalBinds: EmptyLocalBinds not supported yet" trfIpBind :: TransformName n r => Located (IPBind n) -> Trf (Ann AST.ULocalBind (Dom r) RangeStage) trfIpBind = trfLocNoSema $ \case - IPBind (Left (L l ipname)) expr -> AST.ULocalValBind <$> (annContNoSema $ AST.USimpleBind <$> focusOn l (annContNoSema (AST.UVarPat <$> define (trfImplicitName ipname))) - <*> annFromNoSema AnnEqual (AST.UUnguardedRhs <$> trfExpr expr) - <*> nothing " " "" atTheEnd) + IPBind (Left (L l ipname)) expr + -> AST.ULocalValBind + <$> (annContNoSema $ AST.USimpleBind <$> focusOn l (annContNoSema (AST.UVarPat <$> define (trfImplicitName ipname))) + <*> annFromNoSema AnnEqual (AST.UUnguardedRhs <$> trfExpr expr) + <*> nothing " " "" atTheEnd) + IPBind (Right _) _ -> error "trfIpBind: called on typechecked AST" trfLocalSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.ULocalBind (Dom r) RangeStage) trfLocalSig = trfLocNoSema $ \case ts@(TypeSig {}) -> AST.ULocalSignature <$> annContNoSema (trfTypeSig' ts) (FixSig fs) -> AST.ULocalFixity <$> annContNoSema (trfFixitySig fs) + _ -> error "trfLocalSig: not a type or fixity sig" trfTypeSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.UTypeSignature (Dom r) RangeStage) trfTypeSig = trfLocNoSema trfTypeSig' @@ -129,7 +128,8 @@ trfTypeSig' :: TransformName n r => Sig n -> Trf (AST.UTypeSignature (Dom r) RangeStage) trfTypeSig' (TypeSig names typ) = defineTypeVars $ AST.UTypeSignature <$> makeNonemptyList ", " (mapM trfName names) <*> trfType (hswc_body $ hsib_body typ) - +trfTypeSig' _ = error "trfTypeSig': not a type sig" + trfFixitySig :: TransformName n r => FixitySig n -> Trf (AST.UFixitySignature (Dom r) RangeStage) trfFixitySig (FixitySig names (Fixity _ prec dir)) = AST.UFixitySignature <$> transformDir dir
Language/Haskell/Tools/AST/FromGHC/Binds.hs-boot view
@@ -1,15 +1,12 @@ module Language.Haskell.Tools.AST.FromGHC.Binds where -import Outputable as GHC -import RdrName as GHC -import SrcLoc as GHC -import HsBinds as GHC -import HsExpr as GHC -import Language.Haskell.Tools.AST.FromGHC.Monad -import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), AnnListG(..), Dom, RangeStage) +import HsBinds as GHC (HsLocalBinds(..)) +import HsExpr as GHC (Stmt(..), LHsExpr(..)) +import Language.Haskell.Tools.AST (Ann(), AnnMaybeG(), AnnListG(), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.AST.FromGHC.Monad (Trf(..)) +import Language.Haskell.Tools.AST.FromGHC.Names (TransformName(..)) +import SrcLoc as GHC (Located(..)) trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnListG AST.ULocalBind (Dom r) RangeStage) trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybeG AST.ULocalBinds (Dom r) RangeStage)
Language/Haskell/Tools/AST/FromGHC/Decls.hs view
@@ -5,58 +5,48 @@ -- | Functions that convert the declarations of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.Decls where +import ApiAnnotation as GHC (AnnKeywordId(..)) +import Bag as GHC (bagToList) +import BasicTypes as GHC +import BooleanFormula as GHC (BooleanFormula(..)) +import Class as GHC (FunDep(..)) +import ForeignCall as GHC (Safety(..), CExportSpec(..), CCallConv(..)) import qualified GHC -import RdrName as GHC -import Var as GHC -import Class as GHC import HsSyn as GHC +import Name as GHC (Name(..), occNameString, nameOccName) +import Outputable as GHC (Outputable(..), showSDocUnsafe) +import RdrName as GHC (RdrName(..), rdrNameOcc) import SrcLoc as GHC -import HsDecls as GHC -import Name as GHC -import OccName as GHC -import ApiAnnotation as GHC -import FastString as GHC -import BasicTypes as GHC -import Bag as GHC -import ForeignCall as GHC -import Outputable as GHC -import Unique as GHC -import TyCon as GHC -import BooleanFormula as GHC +import TyCon as GHC (Role(..)) import Control.Monad.Reader -import Control.Reference -import Data.Function (on) -import Data.List -import Data.Maybe -import qualified Data.Map as Map +import Control.Reference ((.-), (!~), biplateRef) import Data.Data (toConstr) -import Data.Generics.Uniplate.Data +import Data.Generics.Uniplate.Data () +import Data.List +import Data.Maybe (Maybe(..), fromMaybe) +import Language.Haskell.Tools.AST.FromGHC.Binds +import Language.Haskell.Tools.AST.FromGHC.Exprs (trfExpr) import Language.Haskell.Tools.AST.FromGHC.GHCUtils +import Language.Haskell.Tools.AST.FromGHC.Kinds (trfKindSig, trfKindSig') +import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST.FromGHC.Kinds +import Language.Haskell.Tools.AST.FromGHC.Patterns (trfPattern) +import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH (trfSplice') import Language.Haskell.Tools.AST.FromGHC.Types -import Language.Haskell.Tools.AST.FromGHC.Exprs -import Language.Haskell.Tools.AST.FromGHC.Patterns -import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH -import Language.Haskell.Tools.AST.FromGHC.Binds -import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), AnnListG(..), getRange, Dom, RangeStage) +import Language.Haskell.Tools.AST (Ann(), AnnMaybeG(), AnnListG(), getRange, Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.AST.SemaInfoTypes as AST - -import Data.Dynamic -import Debug.Trace +import Language.Haskell.Tools.AST.SemaInfoTypes as AST (nameInfo) trfDecls :: TransformName n r => [LHsDecl n] -> Trf (AnnListG AST.UDecl (Dom r) RangeStage) -- TODO: filter documentation comments trfDecls decls = addToCurrentScope decls $ makeIndentedListNewlineBefore atTheEnd (mapM trfDecl decls) trfDeclsGroup :: forall n r . TransformName n r => HsGroup n -> Trf (AnnListG AST.UDecl (Dom r) RangeStage) -trfDeclsGroup (HsGroup vals splices tycls insts derivs fixities defaults foreigns warns anns rules vects docs) +trfDeclsGroup (HsGroup vals splices tycls insts derivs fixities defaults foreigns warns anns rules vects _) = do spls <- getDeclSplices let (sigs, bagToList -> binds) = getBindsAndSigs vals alldecls :: [Located (HsDecl n)] @@ -82,6 +72,7 @@ mergeSplice :: [Located (HsDecl n)] -> Located (HsSplice n) -> [Located (HsDecl n)] mergeSplice decls spl@(L spLoc@(RealSrcSpan rss) _) = L spLoc (SpliceD (SpliceDecl spl ExplicitSplice)) : filter (\(L (RealSrcSpan rdsp) _) -> not (rss `containsSpan` rdsp)) decls + mergeSplice _ (L (UnhelpfulSpan {}) _) = error "mergeSplice: no real span" getDeclsToInsert :: Trf [Ann AST.UDecl (Dom r) RangeStage] getDeclsToInsert = do decls <- asks declsToInsert @@ -110,7 +101,7 @@ whereLoc <- tokenLoc AnnWhere if isGoodSrcSpan whereLoc then trfGADT nd name vars ctx kind cons derivs ctxTok consLoc else trfDataDef nd name vars ctx cons derivs ctxTok consLoc - TyClD (ClassDecl ctx name vars funDeps sigs defs typeFuns typeFunDefs docs _) + TyClD (ClassDecl ctx name vars funDeps sigs defs typeFuns typeFunDefs _ _) -> AST.UClassDecl <$> trfCtx (after AnnClass) ctx <*> betweenIfPresent AnnClass AnnWhere (createDeclHead name vars) <*> trfFunDeps funDeps @@ -124,7 +115,7 @@ <*> between AnnInstance AnnEqual (makeInstanceRuleTyVars con pats) <*> makeList " | " (after AnnEqual) (mapM trfConDecl cons) <*> trfMaybe "" "" trfDerivings derivs - InstD (TyFamInstD (TyFamInstDecl (L l (TyFamEqn con pats rhs)) _)) + InstD (TyFamInstD (TyFamInstDecl (L _ (TyFamEqn con pats rhs)) _)) -> AST.UTypeInstDecl <$> between AnnInstance AnnEqual (makeInstanceRuleTyVars con pats) <*> trfType rhs ValD bind -> trfVal bind SigD sig -> trfSig sig @@ -177,6 +168,7 @@ trfSig (InlineSig name (InlinePragma src inl _ phase cl)) = do rng <- asks contRange let parts = map getLoc $ splitLocated (L rng src) + -- TODO: Inlinable, EmptyInlineSpec AST.UPragmaDecl <$> annContNoSema ((case inl of Inline -> AST.UInlinePragma; NoInline -> AST.UNoInlinePragma) <$> trfConlike parts cl <*> trfPhase (pure $ srcSpanStart (getLoc name)) phase @@ -201,6 +193,7 @@ = AST.URecordDecl <$> define (trfName name) <*> (between AnnOpenC AnnCloseC $ trfAnnList ", " trfFieldDecl' flds) trfConDecl' (ConDeclH98 { con_name = name, con_details = InfixCon t1 t2 }) = AST.UInfixConDecl <$> trfType t1 <*> define (trfOperator name) <*> trfType t2 +trfConDecl' (ConDeclGADT {}) = error "trfConDecl': GADT con received" trfGADTConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.UGadtConDecl (Dom r) RangeStage) trfGADTConDecl = trfLocNoSema $ \(ConDeclGADT { con_names = names, con_type = hsib_body -> typ }) @@ -222,7 +215,7 @@ trfDerivings :: TransformName n r => Located [LHsSigType n] -> Trf (Ann AST.UDeriving (Dom r) RangeStage) trfDerivings = trfLocNoSema $ \case - [hsib_body -> typ@(unLoc -> HsTyVar cls)] -> AST.UDerivingOne <$> trfInstanceHead typ + [hsib_body -> typ@(unLoc -> HsTyVar {})] -> AST.UDerivingOne <$> trfInstanceHead typ derivs -> AST.UDerivings <$> trfAnnList ", " trfInstanceHead' (map hsib_body derivs) trfInstanceRule :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage) @@ -275,7 +268,7 @@ trfTypeEq = trfLocNoSema $ \(TyFamEqn name pats rhs) -> AST.UTypeEqn <$> defineTypeVars (focusBefore AnnEqual (combineTypes name (hsib_body pats))) <*> trfType rhs where combineTypes :: TransformName n r => Located n -> [LHsType n] -> Trf (Ann AST.UType (Dom r) RangeStage) - combineTypes name (lhs : rhs : rest) | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs) + combineTypes name [lhs, rhs] | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs) = annContNoSema $ AST.UTyInfix <$> trfType lhs <*> trfOperator name <*> trfType rhs combineTypes name pats = wrapTypes (annLocNoSema (pure $ getLoc name) (AST.UTyVar <$> trfName name)) pats @@ -354,6 +347,7 @@ trfTypeFam' (FamilyDecl OpenTypeFamily name tyVars kindSig injectivity) = AST.UTypeFamily <$> (case unLoc kindSig of KindSig _ -> between AnnType AnnDcolon; _ -> id) (createDeclHead name tyVars) <*> trfFamilyResultSig kindSig injectivity +trfTypeFam' (FamilyDecl (ClosedTypeFamily {}) _ _ _ _) = error "trfTypeFam': closed type family received" trfTypeFamDef :: TransformName n r => Located (TyFamDefltEqn n) -> Trf (Ann AST.UClassElement (Dom r) RangeStage) trfTypeFamDef = trfLocNoSema $ \(TyFamEqn con pats rhs) @@ -413,7 +407,7 @@ in AST.UPatternSynonym <$> trfPatSynLhs id lhs <*> annLocNoSema rhsLoc (trfPatSynRhs dir changedRhs) - where trfPatSynLhs :: TransformName n r => Located n -> HsPatSynDetails (Located n) -> Trf (Ann AST.UPatSynLhs (Dom r) RangeStage) + where trfPatSynLhs :: Located n -> HsPatSynDetails (Located n) -> Trf (Ann AST.UPatSynLhs (Dom r) RangeStage) trfPatSynLhs id (PrefixPatSyn args) = annLocNoSema (pure $ foldLocs (getLoc id : map getLoc args)) $ AST.UNormalPatSyn <$> trfName id <*> trfAnnList " " trfName' args trfPatSynLhs op (InfixPatSyn lhs rhs) @@ -422,22 +416,25 @@ = annLocNoSema (mkSrcSpan (srcSpanStart (getLoc id)) <$> before AnnEqual) $ AST.URecordPatSyn <$> trfName id <*> trfAnnList ", " trfName' (map recordPatSynSelectorId flds) - trfPatSynRhs :: TransformName n r => HsPatSynDir n -> Located (Pat n) -> Trf (AST.UPatSynRhs (Dom r) RangeStage) + trfPatSynRhs :: HsPatSynDir n -> Located (Pat n) -> Trf (AST.UPatSynRhs (Dom r) RangeStage) trfPatSynRhs ImplicitBidirectional pat = AST.UBidirectionalPatSyn <$> trfPattern pat <*> nothing " where " "" atTheEnd trfPatSynRhs (ExplicitBidirectional mg) pat = AST.UBidirectionalPatSyn <$> trfPattern pat <*> (makeJust <$> trfPatSynWhere mg) trfPatSynRhs Unidirectional pat = AST.UOneDirectionalPatSyn <$> trfPattern pat - trfPatSynWhere :: TransformName n r => MatchGroup n (LHsExpr n) -> Trf (Ann AST.UPatSynWhere (Dom r) RangeStage) + + trfPatSynWhere :: MatchGroup n (LHsExpr n) -> Trf (Ann AST.UPatSynWhere (Dom r) RangeStage) trfPatSynWhere (MG { mg_alts = alts }) = annLocNoSema (pure $ getLoc alts) (AST.UPatSynWhere <$> makeIndentedList (after AnnWhere) (mapM (trfMatch (unLoc id)) (unLoc alts))) trfFamilyKind :: TransformName n r => Located (FamilyResultSig n) -> Trf (AnnMaybeG AST.UKindConstraint (Dom r) RangeStage) trfFamilyKind (unLoc -> fr) = case fr of NoSig -> nothing "" " " atTheEnd KindSig k -> trfKindSig (Just k) + TyVarSig {} -> error "trfFamilyKind: TyVarSig not supported yet" trfFamilyResultSig :: TransformName n r => Located (FamilyResultSig n) -> Maybe (LInjectivityAnn n) -> Trf (AnnMaybeG AST.UTypeFamilySpec (Dom r) RangeStage) trfFamilyResultSig (L l fr) Nothing = case fr of NoSig -> nothing "" " " atTheEnd KindSig k -> makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyKind <$> trfKindSig' k) + TyVarSig {} -> error "trfFamilyResultSig: TyVarSig not supported yet" trfFamilyResultSig _ (Just (L l (InjectivityAnn n deps))) = makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyInjectivity <$> (annContNoSema $ AST.UInjectivityAnn <$> trfName n <*> trfAnnList ", " trfName' deps)) @@ -460,8 +457,8 @@ trfCallConv' CCallConv = pure AST.UCCall trfCallConv' CApiConv = pure AST.UCApi trfCallConv' StdCallConv = pure AST.UStdCall --- trfCallConv' PrimCallConv = trfCallConv' JavaScriptCallConv = pure AST.UJavaScript +trfCallConv' PrimCallConv = error "trfCallConv: PrimCallConv not supported" trfSafety :: SrcSpan -> Located Safety -> Trf (AnnMaybeG AST.USafety (Dom r) RangeStage) trfSafety ccLoc lsaf@(L l _) | isGoodSrcSpan l @@ -483,6 +480,7 @@ trfRole = trfLocNoSema $ \case Just Nominal -> pure AST.UNominal Just Representational -> pure AST.URepresentational Just GHC.Phantom -> pure AST.UPhantom + Nothing -> error "trfRole: no role" trfPhase :: Trf SrcLoc -> Activation -> Trf (AnnMaybeG AST.UPhaseControl (Dom r) RangeStage) trfPhase l AlwaysActive = nothing "" " " l @@ -490,6 +488,8 @@ (AST.UPhaseControl <$> nothing "" "" (before AnnCloseS) <*> trfPhaseNum pn) trfPhase _ (ActiveBefore _ pn) = makeJust <$> annLocNoSema (combineSrcSpans <$> tokenLoc AnnOpenS <*> tokenLoc AnnCloseS) (AST.UPhaseControl <$> (makeJust <$> annLocNoSema (tokenLoc AnnTilde) (pure AST.PhaseInvert)) <*> trfPhaseNum pn) +-- TODO +trfPhase _ NeverActive = error "NeverActive pragmas not yet supported" trfPhaseNum :: PhaseNum -> Trf (Ann AST.PhaseNumber (Dom r) RangeStage) trfPhaseNum i = annLocNoSema (tokenLoc AnnVal) $ pure (AST.PhaseNumber $ fromIntegral i)
Language/Haskell/Tools/AST/FromGHC/Exprs.hs view
@@ -7,44 +7,32 @@ -- | Functions that convert the expression-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.Exprs where -import Data.Maybe -import Data.List (partition, find) -import Data.Data (toConstr) import Control.Monad.Reader -import Control.Reference +import Data.Data (toConstr) +import Data.List (partition, find) +import Data.Maybe (Maybe(..), isJust, fromMaybe) +import BasicTypes as GHC (Boxity(..)) import GHC +import Outputable as GHC (Outputable(..), showSDocUnsafe) +import PrelNames as GHC (negateName) import SrcLoc as GHC -import RdrName as GHC -import HsTypes as GHC -import HsPat as GHC -import HsExpr as GHC -import HsBinds as GHC -import HsLit as GHC -import BasicTypes as GHC -import ApiAnnotation as GHC -import FastString as GHC -import Outputable as GHC -import PrelNames as GHC -import DataCon as GHC +import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Binds (trfRhsGuard', trfWhereLocalBinds, trfLocalBinds) +import Language.Haskell.Tools.AST.FromGHC.GHCUtils (GHCName(..), getFieldOccName) +import Language.Haskell.Tools.AST.FromGHC.Literals (trfLiteral', trfOverloadedLit) +import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST.FromGHC.Types -import Language.Haskell.Tools.AST.FromGHC.Literals -import Language.Haskell.Tools.AST.FromGHC.Patterns +import Language.Haskell.Tools.AST.FromGHC.Patterns (trfPattern, trfPattern') import Language.Haskell.Tools.AST.FromGHC.Stmts -import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Binds -import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH -import Language.Haskell.Tools.AST.FromGHC.Monad +import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH (trfBracket', trfSplice', trfQuasiQuotation') +import Language.Haskell.Tools.AST.FromGHC.Types (trfType) import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST.FromGHC.GHCUtils -import Language.Haskell.Tools.AST.SemaInfoTypes +import Language.Haskell.Tools.AST.SemaInfoTypes (ScopeInfo(..), mkScopeInfo) -import Language.Haskell.Tools.AST (Ann(..), AnnListG(..), Dom, RangeStage) +import Language.Haskell.Tools.AST (Ann(), AnnListG(), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST -import Debug.Trace - trfExpr :: forall n r . TransformName n r => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage) -- correction for empty cases trfExpr (L l cs@(HsCase expr (unLoc . mg_alts -> []))) @@ -53,6 +41,7 @@ let actualSpan = case take 3 tokensAfter of [(_, AnnOf), (_, AnnOpenC), (endSpan, AnnCloseC)] -> realSpan `combineSrcSpans` endSpan ((endSpan, AnnOf) : _) -> realSpan `combineSrcSpans` endSpan + _ -> error "trfExpr: case without 'of' '{' or '}' token" annLoc createScopeInfo (pure actualSpan) (trfExpr' cs) trfExpr e = do exprSpls <- asks exprSplices let RealSrcSpan loce = getLoc e @@ -182,8 +171,9 @@ trfAlt' = gTrfAlt' trfExpr gTrfAlt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> Match n (Located (ge n)) -> Trf (AST.UAlt' ae (Dom r) RangeStage) -gTrfAlt' te (Match _ [pat] typ (GRHSs rhss (unLoc -> locBinds))) +gTrfAlt' te (Match _ [pat] _ (GRHSs rhss (unLoc -> locBinds))) = AST.UAlt <$> trfPattern pat <*> gTrfCaseRhss te rhss <*> trfWhereLocalBinds locBinds +gTrfAlt' _ _ = error "gTrfAlt': not exactly one alternative when transforming a case alternative" trfCaseRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.UCaseRhs (Dom r) RangeStage) trfCaseRhss = gTrfCaseRhss trfExpr @@ -226,4 +216,7 @@ = AST.UCaseCmd <$> trfExpr expr <*> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfAlt' trfCmd)) alts) trfCmd' (HsCmdIf _ pred thenExpr elseExpr) = AST.UIfCmd <$> trfExpr pred <*> trfCmd thenExpr <*> trfCmd elseExpr trfCmd' (HsCmdLet (unLoc -> binds) cmd) = addToScope binds (AST.ULetCmd <$> trfLocalBinds binds <*> trfCmd cmd) -trfCmd' (HsCmdDo (unLoc -> stmts) _) = AST.UDoCmd <$> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfDoStmt' trfCmd)) stmts)+trfCmd' (HsCmdDo (unLoc -> stmts) _) = AST.UDoCmd <$> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfDoStmt' trfCmd)) stmts) +-- | TODO: implement +trfCmd' (HsCmdLam {}) = error "trfCmd': cmd lambda not supported yet" +trfCmd' (HsCmdWrap {}) = error "trfCmd': cmd wrap not supported yet"
Language/Haskell/Tools/AST/FromGHC/Exprs.hs-boot view
@@ -1,14 +1,11 @@ module Language.Haskell.Tools.AST.FromGHC.Exprs where -import Outputable as GHC -import RdrName as GHC -import SrcLoc as GHC -import HsExpr as GHC -import Language.Haskell.Tools.AST.FromGHC.Monad -import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST (Ann(..), Dom, RangeStage) +import HsExpr as GHC (HsExpr(..), HsCmd(..)) +import Language.Haskell.Tools.AST (Ann(), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.AST.FromGHC.Monad (Trf(..)) +import Language.Haskell.Tools.AST.FromGHC.Names (TransformName(..)) +import SrcLoc as GHC (Located(..)) trfExpr :: TransformName n r => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage) trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.UExpr (Dom r) RangeStage)
Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs view
@@ -8,23 +8,19 @@ -- | Utility functions defined on the GHC AST representation. module Language.Haskell.Tools.AST.FromGHC.GHCUtils where +import Data.Generics.Uniplate.Data () import Data.List -import qualified Data.Map as Map -import Data.Generics.Uniplate.Operations -import Data.Generics.Uniplate.Data +import Bag (Bag(..), bagToList, unionManyBags) +import ConLike (ConLike(..)) import GHC -import Bag -import RdrName -import OccName -import Name -import Outputable +import Id (Id(..), mkVanillaGlobal) +import OccName (OccName(..)) +import Outputable (Outputable(..), OutputableBndr(..), showSDocUnsafe) +import PatSyn (patSynSig) +import RdrName (RdrName(..), rdrNameOcc, nameRdrName) import SrcLoc -import ConLike -import Id -import PatSyn -import Type -import TysWiredIn +import Type (TyThing(..), mkFunTys) class OutputableBndr name => GHCName name where rdrName :: name -> RdrName @@ -39,6 +35,7 @@ rdrName = id getFromNameUsing _ n = return $ pure (nameRdrName n) getBindsAndSigs (ValBindsIn binds sigs) = (sigs, binds) + getBindsAndSigs _ = error "ValBindsOut: ValBindsOut in parsed source" nameFromId = nameRdrName . getName unpackPostRn rdr _ = rdr @@ -51,6 +48,7 @@ rdrName = nameRdrName getFromNameUsing f n = fmap nameFromId <$> f n getBindsAndSigs (ValBindsOut bindGroups sigs) = (sigs, unionManyBags (map snd bindGroups)) + getBindsAndSigs _ = error "getBindsAndSigs: ValBindsIn in renamed source" nameFromId = getName unpackPostRn _ a = a @@ -72,7 +70,7 @@ Just (AConLike (RealDataCon dc)) -> return $ Just $ mkVanillaGlobal name (dataConUserType dc) Just (AConLike (PatSynCon ps)) -> return $ Just $ mkVanillaGlobal name (createPatSynType ps) Just (ATyCon tc) -> return $ Just $ mkVanillaGlobal name (tyConKind tc) - Nothing -> return Nothing + _ -> return Nothing where createPatSynType patSyn = case patSynSig patSyn of (_, _, _, _, args, res) -> mkFunTys args res -- | Get names from the GHC AST @@ -117,7 +115,8 @@ hsGetNames (HsDataDefn {dd_cons = ctors}) = hsGetNames ctors instance (GHCName n, HsHasName n) => HsHasName (ConDecl n) where - hsGetNames (ConDeclGADT {con_names = names, con_type = (HsIB _ (L l (HsRecTy flds)))}) = hsGetNames names ++ hsGetNames flds + hsGetNames (ConDeclGADT {con_names = names, con_type = (HsIB _ (L _ (HsRecTy flds)))}) + = hsGetNames names ++ hsGetNames flds hsGetNames (ConDeclGADT {con_names = names}) = hsGetNames names hsGetNames (ConDeclH98 {con_name = name, con_details = details}) = hsGetNames name ++ hsGetNames details @@ -131,7 +130,7 @@ instance (GHCName n, HsHasName n) => HsHasName (FieldOcc n) where hsGetNames (FieldOcc _ pr) = gunpackPostRn [] (hsGetNames :: n -> [Name]) pr -instance (GHCName n, HsHasName n) => HsHasName (Sig n) where +instance (HsHasName n) => HsHasName (Sig n) where hsGetNames (TypeSig n _) = hsGetNames n hsGetNames (PatSynSig n _) = hsGetNames n hsGetNames _ = [] @@ -152,6 +151,7 @@ hsGetNames (PatBind {pat_lhs = pat}) = hsGetNames pat hsGetNames (VarBind {var_id = id}) = hsGetNames id hsGetNames (PatSynBind (PSB {psb_id = id})) = hsGetNames id + hsGetNames _ = error "hsGetNames: called on compiler-generated binding" instance HsHasName n => HsHasName (ParStmtBlock l n) where hsGetNames (ParStmtBlock _ binds _) = hsGetNames binds
Language/Haskell/Tools/AST/FromGHC/Kinds.hs view
@@ -4,29 +4,26 @@ -- | Functions that convert the kind-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.Kinds where -import SrcLoc as GHC -import RdrName as GHC +import ApiAnnotation as GHC (AnnKeywordId(..)) +import FastString as GHC (unpackFS) import HsTypes as GHC -import OccName as GHC -import Name as GHC -import ApiAnnotation as GHC -import Outputable as GHC -import FastString as GHC +import Name as GHC (occNameString, nameOccName, isWiredInName) +import OccName as GHC (occNameString) +import Outputable as GHC (Outputable(..), showSDocUnsafe) +import RdrName as GHC (RdrName(..)) +import SrcLoc as GHC -import Control.Monad.Reader +import Control.Monad.Reader (Monad(..), asks) import Data.Data (toConstr) -import Language.Haskell.Tools.AST.FromGHC.GHCUtils -import Language.Haskell.Tools.AST.FromGHC.Literals -import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST.FromGHC.Monad +import Language.Haskell.Tools.AST (Ann(), AnnMaybeG(), Dom, RangeStage, HasNoSemanticInfo) +import qualified Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.AST.FromGHC.GHCUtils (GHCName(..), cleanHsType) +import Language.Haskell.Tools.AST.FromGHC.Monad (TrfInput(..), Trf(..), transformingPossibleVar) +import Language.Haskell.Tools.AST.FromGHC.Names (TransformName(..), trfName) import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), Dom, RangeStage, HasNoSemanticInfo) -import qualified Language.Haskell.Tools.AST as AST -import Debug.Trace - trfKindSig :: TransformName n r => Maybe (LHsKind n) -> Trf (AnnMaybeG AST.UKindConstraint (Dom r) RangeStage) trfKindSig = trfMaybe "" "" trfKindSig' @@ -58,9 +55,9 @@ trfPromoted' :: (TransformName n r, HasNoSemanticInfo (Dom r) a) => (HsType n -> Trf (a (Dom r) RangeStage)) -> HsType n -> Trf (AST.UPromoted a (Dom r) RangeStage) -trfPromoted' f (HsTyLit (HsNumTy _ int)) = pure $ AST.UPromotedInt int -trfPromoted' f (HsTyLit (HsStrTy _ str)) = pure $ AST.UPromotedString (unpackFS str) -trfPromoted' f (HsTyVar name) = AST.UPromotedCon <$> trfName name +trfPromoted' _ (HsTyLit (HsNumTy _ int)) = pure $ AST.UPromotedInt int +trfPromoted' _ (HsTyLit (HsStrTy _ str)) = pure $ AST.UPromotedString (unpackFS str) +trfPromoted' _ (HsTyVar name) = AST.UPromotedCon <$> trfName name trfPromoted' f (HsExplicitListTy _ elems) = AST.UPromotedList <$> between AnnOpenS AnnCloseS (trfAnnList ", " f elems) trfPromoted' f (HsExplicitTupleTy _ elems) = AST.UPromotedTuple <$> between AnnOpenP AnnCloseP (trfAnnList ", " f elems) trfPromoted' _ t = asks contRange >>= \r -> error $ "Unknown promoted type/kind: " ++ (showSDocUnsafe (ppr t) ++ " at: " ++ show r)
Language/Haskell/Tools/AST/FromGHC/Literals.hs view
@@ -1,21 +1,15 @@ -- | Functions that convert the literals of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.Literals where -import qualified Data.ByteString.Char8 as BS - -import SrcLoc as GHC -import ApiAnnotation as GHC -import FastString as GHC -import BasicTypes as GHC -import HsLit as GHC -import HsTypes as GHC +import qualified Data.ByteString.Char8 as BS (foldr) -import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST.FromGHC.Monad -import Language.Haskell.Tools.AST.FromGHC.Utils +import BasicTypes as GHC (FractionalLit(..)) +import FastString as GHC (unpackFS) +import HsLit as GHC (OverLitVal(..), HsLit(..)) import Language.Haskell.Tools.AST (Dom, RangeStage) -import qualified Language.Haskell.Tools.AST as AST +import qualified Language.Haskell.Tools.AST as AST (ULiteral(..), Dom(..), RangeStage(..)) +import Language.Haskell.Tools.AST.FromGHC.Monad (Trf(..)) trfLiteral' :: HsLit -> Trf (AST.ULiteral (Dom r) RangeStage) trfLiteral' (HsChar _ ch) = pure $ AST.UCharLit ch
Language/Haskell/Tools/AST/FromGHC/Modules.hs view
@@ -9,79 +9,37 @@ -- Also contains the entry point of the transformation that collects the information from different GHC AST representations. module Language.Haskell.Tools.AST.FromGHC.Modules where +import Control.Monad.Reader import Control.Reference hiding (element) -import Data.Maybe -import Data.Function (on) +import Data.Generics.Uniplate.Data () import Data.List as List -import Data.Char -import Data.Map as Map hiding (map, filter) -import Data.IORef -import Data.Data -import Data.Generics.Uniplate.Operations -import Data.Generics.Uniplate.Data -import Control.Applicative -import Control.Monad -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State +import Data.Map as Map (fromList, lookup) +import Data.Maybe -import Avail as GHC +import BasicTypes as GHC (WarningTxt(..), StringLiteral(..)) +import DynFlags as GHC (xopt_set) +import ErrUtils as GHC (pprErrMsgBagWithLoc) +import FastString as GHC (unpackFS) import GHC -import GhcMonad as GHC -import ApiAnnotation as GHC -import RdrName as GHC +import HscTypes as GHC (WarningTxt(..), ModSummary(..), HscEnv(..)) +import Language.Haskell.TH.LanguageExtensions (Extension(..)) import Name as GHC hiding (varName) -import Id as GHC -import TysWiredIn as GHC +import Outputable as GHC (vcat, showSDocUnsafe, (<+>)) +import RdrName as GHC +import RnEnv as GHC (mkUnboundNameRdr) +import RnExpr as GHC (rnLExpr) import SrcLoc as GHC -import FastString as GHC -import Module as GHC -import BasicTypes as GHC -import HsSyn as GHC -import HscTypes as GHC -import Outputable as GHC -import TyCon as GHC -import ConLike as GHC -import DataCon as GHC -import Bag as GHC -import Var as GHC -import PatSyn as GHC -import Type as GHC -import Unique as GHC -import CoAxiom as GHC -import DynFlags as GHC -import TcEvidence as GHC import TcRnMonad as GHC -import RnEnv as GHC -import RnExpr as GHC -import ErrUtils as GHC -import PrelNames as GHC -import NameEnv as GHC -import TcRnDriver as GHC -import TcExpr as GHC -import TcType as GHC -import UniqSupply as GHC -import UniqFM as GHC -import HeaderInfo as GHC -import Language.Haskell.TH.LanguageExtensions -import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), AnnListG(..), Dom, IdDom, RangeStage - , semanticInfo, sourceInfo, semantics, annotation, nodeSpan, semaTraverse) +import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(), AnnListG(..), Dom, RangeStage + , sourceInfo, semantics, annotation, nodeSpan) import qualified Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.AST.SemaInfoTypes as AST - -import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST.FromGHC.Decls +import Language.Haskell.Tools.AST.FromGHC.Decls (trfDecls, trfDeclsGroup) +import Language.Haskell.Tools.AST.FromGHC.GHCUtils (HsHasName(..)) import Language.Haskell.Tools.AST.FromGHC.Monad +import Language.Haskell.Tools.AST.FromGHC.Names (TransformName(..), trfName) import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST.FromGHC.GHCUtils - -import Debug.Trace - -createModuleInfo :: ModSummary -> Trf (AST.ModuleInfo GHC.Name) -createModuleInfo mod = do let prelude = xopt ImplicitPrelude $ ms_hspp_opts mod - (_,preludeImports) <- if prelude then getImportedNames "Prelude" Nothing else return (ms_mod mod, []) - return $ mkModuleInfo (ms_mod mod) (case ms_hsc_src mod of HsSrcFile -> False; _ -> True) preludeImports +import Language.Haskell.Tools.AST.SemaInfoTypes as AST (nameInfo, implicitNames, importedNames) trfModule :: ModSummary -> Located (HsModule RdrName) -> Trf (Ann AST.UModule (Dom RdrName) RangeStage) trfModule mod = trfLocCorrect (createModuleInfo mod) (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) $ @@ -103,22 +61,21 @@ getSourceAndInfo :: Ann AST.UQualifiedName (Dom RdrName) RangeStage -> Maybe (SrcSpan, RdrName) getSourceAndInfo n = (,) <$> (n ^? annotation&sourceInfo&nodeSpan) <*> (n ^? semantics&nameInfo) - trfModuleRename' preludeImports hsMod@(HsModule name exports _ decls deprec _) = do + trfModuleRename' preludeImports hsMod@(HsModule name exports _ _ deprec _) = do transformedImports <- orderAnnList <$> (trfImports imports) addToScope (concat @[] (transformedImports ^? AST.annList&semantics&importedNames) ++ preludeImports) - $ loadSplices mod hsMod gr $ setOriginalNames originalNames . setDeclsToInsert roleAnnots + $ loadSplices hsMod gr $ setOriginalNames originalNames . setDeclsToInsert roleAnnots $ AST.UModule <$> trfFilePragmas <*> trfModuleHead name (case (exports, exps) of (Just (L l _), Just ie) -> Just (L l ie) _ -> Nothing) deprec <*> return transformedImports <*> trfDeclsGroup gr -loadSplices :: ModSummary -> HsModule RdrName -> HsGroup Name -> Trf a -> Trf a -loadSplices mod hsMod group trf = do +loadSplices :: HsModule RdrName -> HsGroup Name -> Trf a -> Trf a +loadSplices hsMod group trf = do let declSpls = map (\(SpliceDecl sp _) -> sp) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)] - declLocs = map getLoc declSpls - let exprSpls = catMaybes $ map (\case HsSpliceE sp -> Just sp; _ -> Nothing) $ hsMod ^? biplateRef :: [HsSplice RdrName] + exprSpls = catMaybes $ map (\case HsSpliceE sp -> Just sp; _ -> Nothing) $ hsMod ^? biplateRef :: [HsSplice RdrName] typeSpls = catMaybes $ map (\case HsSpliceTy sp _ -> Just sp; _ -> Nothing) $ hsMod ^? biplateRef :: [HsSplice RdrName] -- initialize reader environment env <- liftGhc getSession @@ -157,6 +114,7 @@ trfModuleHead _ Nothing _ = nothing "" "" moduleHeadPos where moduleHeadPos = after AnnClose >>= \case loc@(RealSrcLoc _) -> return loc _ -> atTheStart +trfModuleHead Nothing (Just _) _ = error "trfModuleHead: no head but has exports" trfFilePragmas :: Trf (AnnListG AST.UFilePragma (Dom r) RangeStage) trfFilePragmas = do pragmas <- asks pragmaComms @@ -165,8 +123,8 @@ makeList "" atTheStart $ pure $ orderDefs $ languagePragmas ++ optionsPragmas trfLanguagePragma :: Located String -> Trf (Ann AST.UFilePragma (Dom r) RangeStage) -trfLanguagePragma lstr@(L l str) = annLocNoSema (pure l) (AST.ULanguagePragma <$> makeList ", " (pure $ srcSpanStart $ getLoc $ last pragmaElems) - (mapM (trfLocNoSema (pure . AST.ULanguageExtension)) extensions)) +trfLanguagePragma lstr@(L l _) = annLocNoSema (pure l) (AST.ULanguagePragma <$> makeList ", " (pure $ srcSpanStart $ getLoc $ last pragmaElems) + (mapM (trfLocNoSema (pure . AST.ULanguageExtension)) extensions)) where pragmaElems = splitLocated lstr extensions = init $ drop 2 pragmaElems @@ -202,7 +160,7 @@ <$> (combineSrcSpans <$> asks (srcLocSpan . srcSpanStart . contRange) <*> (srcLocSpan . srcSpanEnd <$> tokenLoc AnnWhere)) trfImport :: TransformName n r => LImportDecl n -> Trf (Ann AST.UImportDecl (Dom r) RangeStage) -trfImport (L l impDecl@(GHC.ImportDecl src name pkg isSrc isSafe isQual isImpl declAs declHiding)) = +trfImport (L l impDecl@(GHC.ImportDecl _ name pkg isSrc isSafe isQual _ declAs declHiding)) = let -- default positions of optional parts of an import declaration annBeforeQual = if isSrc then AnnClose else AnnImport annBeforeSafe = if isQual then AnnQualified else annBeforeQual @@ -226,24 +184,30 @@ trfImportSpecs :: TransformName n r => Maybe (Bool, Located [LIE n]) -> Trf (AnnMaybeG AST.UImportSpec (Dom r) RangeStage) trfImportSpecs (Just (True, l)) - = makeJust <$> trfLocNoSema (\specs -> AST.UImportSpecHiding <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l + = makeJust <$> trfLocNoSema (\specs -> AST.UImportSpecHiding <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec (removeDuplicates specs)))) l trfImportSpecs (Just (False, l)) - = makeJust <$> trfLocNoSema (\specs -> AST.UImportSpecList <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l + = makeJust <$> trfLocNoSema (\specs -> AST.UImportSpecList <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec (removeDuplicates specs)))) l trfImportSpecs Nothing = nothing " " "" atTheEnd trfIESpec :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.UIESpec (Dom r) RangeStage)) trfIESpec = trfMaybeLocNoSema trfIESpec' trfIESpec' :: TransformName n r => IE n -> Trf (Maybe (AST.UIESpec (Dom r) RangeStage)) -trfIESpec' (IEVar n) = Just <$> (AST.UIESpec <$> trfName n <*> (nothing "(" ")" atTheEnd)) -trfIESpec' (IEThingAbs n) = Just <$> (AST.UIESpec <$> trfName n <*> (nothing "(" ")" atTheEnd)) +trfIESpec' (IEVar n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName n <*> (nothing "(" ")" atTheEnd)) +trfIESpec' (IEThingAbs n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName n <*> (nothing "(" ")" atTheEnd)) trfIESpec' (IEThingAll n) - = Just <$> (AST.UIESpec <$> trfName n <*> (makeJust <$> (annLocNoSema (tokenLoc AnnDotdot) (pure AST.USubSpecAll)))) + = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName n <*> (makeJust <$> (annLocNoSema (tokenLoc AnnDotdot) (pure AST.USubSpecAll)))) trfIESpec' (IEThingWith n _ ls _) - = Just <$> (AST.UIESpec <$> trfName n + = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName n <*> (makeJust <$> between AnnOpenP AnnCloseP (annContNoSema $ AST.USubSpecList <$> makeList ", " (after AnnOpenP) (mapM trfName ls)))) trfIESpec' _ = pure Nothing + +trfImportModifier :: Trf (AnnMaybeG AST.UImportModifier (Dom r) RangeStage) +trfImportModifier = do + patLoc <- tokenLoc AnnPattern + if isGoodSrcSpan patLoc then makeJust <$> annLocNoSema (return patLoc) (return AST.UImportPattern) + else nothing " " "" atTheStart trfModuleName :: Located ModuleName -> Trf (Ann AST.UModuleName (Dom r) RangeStage) trfModuleName = trfLocNoSema trfModuleName'
Language/Haskell/Tools/AST/FromGHC/Monad.hs view
@@ -2,20 +2,17 @@ -- during the conversion from GHC AST to our representation. module Language.Haskell.Tools.AST.FromGHC.Monad where -import SrcLoc -import GHC -import Name -import ApiAnnotation -import Outputable (ppr, showSDocUnsafe) +import ApiAnnotation (ApiAnnKey(..)) import Control.Monad.Reader -import Language.Haskell.Tools.AST.FromGHC.SourceMap -import Language.Haskell.Tools.AST.FromGHC.GHCUtils -import Data.Map as Map import Data.Function (on) -import Data.Maybe +import Data.Map as Map (Map(..), lookup, empty) +import Data.Maybe (fromMaybe) +import GHC import Language.Haskell.Tools.AST - -import Debug.Trace +import Language.Haskell.Tools.AST.FromGHC.GHCUtils (HsHasName(..), rdrNameStr) +import Language.Haskell.Tools.AST.FromGHC.SourceMap (SourceMap(..), annotationsToSrcMap) +import Name (Name(..), isVarName, isTyVarName) +import SrcLoc -- | The transformation monad type type Trf = ReaderT TrfInput Ghc
Language/Haskell/Tools/AST/FromGHC/Names.hs view
@@ -13,35 +13,22 @@ -- | Functions that convert the basic elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.Names where -import Control.Monad.Reader -import Data.List.Split -import Data.Char -import qualified Data.ByteString.Char8 as BS - -import Control.Reference hiding (element) +import Control.Monad.Reader ((=<<), asks) +import Data.Char (isDigit, isLetter) +import FastString as GHC (FastString(..), unpackFS) import HsSyn as GHC -import Module as GHC -import RdrName as GHC -import Id as GHC -import Name as GHC hiding (Name, occName) +import Name as GHC (isSymOcc) import qualified Name as GHC (Name) -import Outputable as GHC +import RdrName as GHC (RdrName(..)) import SrcLoc as GHC -import BasicTypes as GHC -import FastString as GHC -import ApiAnnotation as GHC -import ForeignCall as GHC -import CoAxiom as GHC -import Bag as GHC -import Data.Data (Data) -import Language.Haskell.Tools.AST (Ann(..), AnnListG(..), AnnMaybeG(..), SemanticInfo(..), RangeStage, Dom, annotation, semanticInfo) +import Language.Haskell.Tools.AST (Ann(..), AnnListG(), RangeStage, Dom) import qualified Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.AST.FromGHC.Monad -import Language.Haskell.Tools.AST.FromGHC.Utils import Language.Haskell.Tools.AST.FromGHC.GHCUtils +import Language.Haskell.Tools.AST.FromGHC.Monad (TrfInput(..), Trf(..), getOriginalName) +import Language.Haskell.Tools.AST.FromGHC.Utils trfOperator :: TransformName n r => Located n -> Trf (Ann AST.UOperator (Dom r) RangeStage) trfOperator = trfLocNoSema trfOperator' @@ -62,17 +49,15 @@ where loc = mkSrcSpan <$> (updateCol (+1) <$> atTheStart) <*> (updateCol (subtract 1) <$> atTheEnd) trfAmbiguousFieldName :: TransformName n r => Located (AmbiguousFieldOcc n) -> Trf (Ann AST.UName (Dom r) RangeStage) -trfAmbiguousFieldName all@(L l af) = trfAmbiguousFieldName' l af +trfAmbiguousFieldName (L l af) = trfAmbiguousFieldName' l af trfAmbiguousFieldName' :: forall n r . TransformName n r => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.UName (Dom r) RangeStage) trfAmbiguousFieldName' l (Unambiguous (L _ rdr) pr) = annLocNoSema (pure l) $ trfName' (unpackPostRn @n rdr pr) -- no Id transformation is done, so we can basically ignore the postTC value trfAmbiguousFieldName' _ (Ambiguous (L l rdr) _) - = do locals <- asks localsInScope - isDefining <- asks defining - annLocNoSema (pure l) - $ AST.UNormalName - <$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfNameStr (rdrNameStr rdr)) + = annLocNoSema (pure l) + $ AST.UNormalName + <$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfNameStr (rdrNameStr rdr)) class (DataId n, Eq n, GHCName n) => TransformableName n where correctNameString :: n -> Trf String @@ -110,7 +95,7 @@ annContNoSema (AST.UImplicitName <$> annLoc (createImplicitNameInfo nstr) (pure rng') (AST.nameFromList <$> trfNameStr nstr)) trfQualifiedName :: TransformName n r => Located n -> Trf (Ann AST.UQualifiedName (Dom r) RangeStage) -trfQualifiedName name@(L l n) = annLoc (createNameInfo (transformName n)) (pure l) (trfQualifiedName' n) +trfQualifiedName (L l n) = annLoc (createNameInfo (transformName n)) (pure l) (trfQualifiedName' n) trfQualifiedName' :: TransformName n r => n -> Trf (AST.UQualifiedName (Dom r) RangeStage) trfQualifiedName' n = AST.nameFromList <$> (trfNameStr =<< correctNameString n)
Language/Haskell/Tools/AST/FromGHC/Patterns.hs view
@@ -6,27 +6,24 @@ -- | Functions that convert the pattern-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.Patterns where -import SrcLoc as GHC -import RdrName as GHC -import HsTypes as GHC -import HsPat as GHC -import HsLit as GHC -import ApiAnnotation as GHC -import BasicTypes as GHC -import Unique as GHC -import Debug.Trace +import ApiAnnotation as GHC (AnnKeywordId(..)) +import BasicTypes as GHC (Boxity(..)) import Data.List -import Language.Haskell.Tools.AST.FromGHC.GHCUtils +import HsLit as GHC (HsOverLit(..)) +import HsPat as GHC +import HsTypes as GHC (HsWildCardBndrs(..), HsImplicitBndrs(..), HsConDetails(..)) +import Language.Haskell.Tools.AST.FromGHC.GHCUtils (getFieldOccName) +import SrcLoc as GHC -import Language.Haskell.Tools.AST.FromGHC.Names -import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH -import Language.Haskell.Tools.AST.FromGHC.Literals -import Language.Haskell.Tools.AST.FromGHC.Types -import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Exprs -import Language.Haskell.Tools.AST.FromGHC.Monad +import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Exprs (trfExpr) +import Language.Haskell.Tools.AST.FromGHC.Literals (trfLiteral', trfOverloadedLit) +import Language.Haskell.Tools.AST.FromGHC.Monad (Trf(..), define) +import Language.Haskell.Tools.AST.FromGHC.Names (TransformName(..), trfOperator, trfName) +import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH (trfSplice') +import Language.Haskell.Tools.AST.FromGHC.Types (trfType) import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST (Ann(..), Dom, RangeStage) +import Language.Haskell.Tools.AST (Ann(), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST trfPattern :: TransformName n r => Located (Pat n) -> Trf (Ann AST.UPattern (Dom r) RangeStage) @@ -40,7 +37,7 @@ -- | Locations for right-associative infix patterns are incorrect in GHC AST correctPatternLoc :: Located (Pat n) -> Located (Pat n) -correctPatternLoc (L l p@(ConPatIn name (InfixCon left right))) +correctPatternLoc (L _ p@(ConPatIn _ (InfixCon left right))) = L (getLoc (correctPatternLoc left) `combineSrcSpans` getLoc (correctPatternLoc right)) p correctPatternLoc p = p @@ -53,6 +50,7 @@ trfPattern' (BangPat pat) = AST.UBangPat <$> trfPattern pat trfPattern' (ListPat pats _ _) = AST.UListPat <$> trfAnnList ", " trfPattern' pats trfPattern' (TuplePat pats Boxed _) = AST.UTuplePat <$> trfAnnList ", " trfPattern' pats +trfPattern' (TuplePat pats Unboxed _) = AST.UUnboxTuplePat <$> trfAnnList ", " trfPattern' pats trfPattern' (PArrPat pats _) = AST.UParArrPat <$> trfAnnList ", " trfPattern' pats trfPattern' (ConPatIn name (PrefixCon args)) = AST.UAppPat <$> trfName name <*> trfAnnList " " trfPattern' args trfPattern' (ConPatIn name (RecCon (HsRecFields flds _))) = AST.URecPat <$> trfName name <*> trfAnnList ", " trfPatternField' flds @@ -63,8 +61,8 @@ trfPattern' (SigPatIn pat (hswc_body . hsib_body -> typ)) = AST.UTypeSigPat <$> trfPattern pat <*> trfType typ trfPattern' (NPat (ol_val . unLoc -> lit) _ _ _) = AST.ULitPat <$> annContNoSema (trfOverloadedLit lit) trfPattern' (NPlusKPat id (L l lit) _ _ _ _) = AST.UNPlusKPat <$> define (trfName id) <*> annLocNoSema (pure l) (trfOverloadedLit (ol_val lit)) --- coercion pattern introduced by GHC -trfPattern' (CoPat _ pat _) = trfPattern' pat +trfPattern' (CoPat _ pat _) = trfPattern' pat -- coercion pattern introduced by GHC +trfPattern' _ = error "trfPattern': cannot be used on patterns generated by the compiler" trfPatternField' :: TransformName n r => HsRecField n (LPat n) -> Trf (AST.UPatternField (Dom r) RangeStage) trfPatternField' (HsRecField id arg False) = AST.UNormalFieldPattern <$> trfName (getFieldOccName id) <*> trfPattern arg
Language/Haskell/Tools/AST/FromGHC/SourceMap.hs view
@@ -2,14 +2,13 @@ -- | A representation of the tokens that build up the source file. module Language.Haskell.Tools.AST.FromGHC.SourceMap where -import ApiAnnotation -import Data.Maybe -import Data.Map as Map +import ApiAnnotation (AnnKeywordId(..), ApiAnnKey(..)) import Data.List as List -import Safe +import Data.Map as Map +import Data.Maybe (Maybe(..), maybe, fromMaybe) +import Safe (headMay) import SrcLoc as GHC -import FastString as GHC -- We store tokens in the source map so it is not a problem that they cannot overlap type SourceMap = (Map AnnKeywordId (Map SrcLoc SrcLoc), Map SrcLoc (SrcSpan, AnnKeywordId))
Language/Haskell/Tools/AST/FromGHC/Stmts.hs view
@@ -5,26 +5,20 @@ -- | Functions that convert the statement-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.Stmts where -import Data.Maybe -import Control.Monad.Reader +import Control.Monad.Reader (MonadReader(..)) -import SrcLoc as GHC -import RdrName as GHC -import HsTypes as GHC -import HsPat as GHC +import ApiAnnotation as GHC (AnnKeywordId(..)) import HsExpr as GHC -import ApiAnnotation as GHC - -import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST.FromGHC.Types -import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Exprs -import Language.Haskell.Tools.AST.FromGHC.Patterns -import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Binds -import Language.Haskell.Tools.AST.FromGHC.Monad -import Language.Haskell.Tools.AST.FromGHC.Utils +import SrcLoc as GHC -import Language.Haskell.Tools.AST (Ann(..), AnnListG(..), AnnMaybeG(..), Dom, RangeStage) +import Language.Haskell.Tools.AST (Ann(), AnnListG(), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST +import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Binds (trfLocalBinds) +import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Exprs (trfExpr) +import Language.Haskell.Tools.AST.FromGHC.Monad (TrfInput(..), Trf(..), addToScope) +import Language.Haskell.Tools.AST.FromGHC.Names (TransformName(..)) +import Language.Haskell.Tools.AST.FromGHC.Patterns (trfPattern) +import Language.Haskell.Tools.AST.FromGHC.Utils trfDoStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.UStmt (Dom r) RangeStage) trfDoStmt = trfLocNoSema trfDoStmt' @@ -35,9 +29,10 @@ gTrfDoStmt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> Stmt n (Located (ge n)) -> Trf (AST.UStmt' ae (Dom r) RangeStage) gTrfDoStmt' et (BindStmt pat expr _ _ _) = AST.UBindStmt <$> trfPattern pat <*> et expr gTrfDoStmt' et (BodyStmt expr _ _ _) = AST.UExprStmt <$> et expr -gTrfDoStmt' et (LetStmt (unLoc -> binds)) = AST.ULetStmt <$> addToScope binds (trfLocalBinds binds) +gTrfDoStmt' _ (LetStmt (unLoc -> binds)) = AST.ULetStmt <$> addToScope binds (trfLocalBinds binds) gTrfDoStmt' et (LastStmt body _ _) = AST.UExprStmt <$> et body gTrfDoStmt' et (RecStmt { recS_stmts = stmts }) = AST.URecStmt <$> trfAnnList "," (gTrfDoStmt' et) stmts +gTrfDoStmt' _ _ = error "gTrfDoStmt': not a simple do statement" trfListCompStmts :: TransformName n r => [Located (Stmt n (LHsExpr n))] -> Trf (AnnListG AST.UListCompBody (Dom r) RangeStage) trfListCompStmts [unLoc -> ParStmt blocks _ _ _, unLoc -> (LastStmt {})] @@ -53,7 +48,7 @@ (AST.UListCompBody <$> makeList "," (pure $ srcSpanStart ann) (concat <$> trfScopedSequence trfListCompStmt others))) trfListCompStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf [Ann AST.UCompStmt (Dom r) RangeStage] -trfListCompStmt (L l trst@(TransStmt { trS_stmts = stmts })) +trfListCompStmt (L _ trst@(TransStmt { trS_stmts = stmts })) = (++) <$> (concat <$> local (\s -> s { contRange = mkSrcSpan (srcSpanStart (contRange s)) (srcSpanEnd (getLoc (last stmts))) }) (trfScopedSequence trfListCompStmt stmts)) <*> ((:[]) <$> extractActualStmt trst) -- last statement is extracted @@ -66,16 +61,18 @@ -> addAnnotation by using (AST.UThenStmt <$> trfExpr using <*> trfMaybe "," "" trfExpr by) TransStmt { trS_form = GroupForm, trS_using = using, trS_by = by } -> addAnnotation by using (AST.UGroupStmt <$> trfMaybe "," "" trfExpr by <*> (makeJust <$> trfExpr using)) + _ -> error "extractActualStmt: called on a statement that is not then or group" where addAnnotation by using = annLocNoSema (combineSrcSpans (getLoc using) . combineSrcSpans (maybe noSrcSpan getLoc by) <$> tokenLocBack AnnThen) getNormalStmts :: [Located (Stmt n (LHsExpr n))] -> [Located (Stmt n (LHsExpr n))] -getNormalStmts (L _ (LastStmt body _ _) : rest) = getNormalStmts rest +getNormalStmts (L _ (LastStmt _ _ _) : rest) = getNormalStmts rest getNormalStmts (stmt : rest) = stmt : getNormalStmts rest getNormalStmts [] = [] getLastStmt :: [Located (Stmt n (LHsExpr n))] -> Located (HsExpr n) -getLastStmt (L _ (LastStmt body _ _) : rest) = body +getLastStmt (L _ (LastStmt body _ _) : _) = body getLastStmt (_ : rest) = getLastStmt rest +getLastStmt [] = error "getLastStmt: empty"
Language/Haskell/Tools/AST/FromGHC/TH.hs view
@@ -1,25 +1,23 @@ -- | Functions that convert the Template-Haskell-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.TH where -import Control.Monad.Reader +import Control.Monad.Reader (asks) -import SrcLoc as GHC -import RdrName as GHC -import HsTypes as GHC -import HsExpr as GHC -import ApiAnnotation as GHC -import FastString as GHC -import OccName as GHC +import ApiAnnotation as GHC (AnnKeywordId(..)) +import FastString as GHC (unpackFS) +import HsExpr as GHC (HsSplice(..), HsExpr(..), HsBracket(..)) +import OccName as GHC (occNameString) +import RdrName as GHC (rdrNameOcc) import SrcLoc as GHC -import Language.Haskell.Tools.AST.FromGHC.Monad +import Language.Haskell.Tools.AST.FromGHC.Decls (trfDecls, trfDeclsGroup) +import Language.Haskell.Tools.AST.FromGHC.Exprs (trfExpr, createScopeInfo) +import Language.Haskell.Tools.AST.FromGHC.GHCUtils (GHCName(..)) +import Language.Haskell.Tools.AST.FromGHC.Monad (TrfInput(..), Trf(..)) +import Language.Haskell.Tools.AST.FromGHC.Names (TransformName(..), trfName') +import Language.Haskell.Tools.AST.FromGHC.Patterns (trfPattern) +import Language.Haskell.Tools.AST.FromGHC.Types (trfType) import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST.FromGHC.Decls -import Language.Haskell.Tools.AST.FromGHC.Exprs -import Language.Haskell.Tools.AST.FromGHC.Types -import Language.Haskell.Tools.AST.FromGHC.Patterns -import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST.FromGHC.GHCUtils import Language.Haskell.Tools.AST (Ann, Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST @@ -32,6 +30,7 @@ where quoterLoc = mkSrcSpan (updateCol (subtract (1 + length (occNameString $ rdrNameOcc $ rdrName id))) (srcSpanStart l)) (updateCol (subtract 1) (srcSpanStart l)) strLoc = mkSrcSpan (srcSpanStart l) (updateCol (subtract 2) (srcSpanEnd l)) +trfQuasiQuotation' _ = error "trfQuasiQuotation': splice received" trfSplice :: TransformName n r => Located (HsSplice n) -> Trf (Ann AST.USplice (Dom r) RangeStage) trfSplice = trfLocNoSema trfSplice' @@ -39,6 +38,7 @@ trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.USplice (Dom r) RangeStage) trfSplice' (HsTypedSplice _ expr) = AST.UParenSplice <$> trfCorrectDollar expr trfSplice' (HsUntypedSplice _ expr) = AST.UParenSplice <$> trfCorrectDollar expr +trfSplice' (HsQuasiQuote {}) = error "trfSplice': quasi quotation received" trfCorrectDollar :: TransformName n r => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage) trfCorrectDollar expr =
Language/Haskell/Tools/AST/FromGHC/TH.hs-boot view
@@ -1,14 +1,11 @@ module Language.Haskell.Tools.AST.FromGHC.TH where -import SrcLoc as GHC -import RdrName as GHC -import HsTypes as GHC -import HsExpr as GHC -import Language.Haskell.Tools.AST.FromGHC.Monad -import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST.FromGHC.Names -import Language.Haskell.Tools.AST (Ann(..), Dom, RangeStage) +import HsExpr as GHC (HsSplice(..), HsBracket(..)) +import Language.Haskell.Tools.AST (Ann(), Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.AST.FromGHC.Monad (Trf(..)) +import Language.Haskell.Tools.AST.FromGHC.Names (TransformName(..)) +import SrcLoc as GHC (Located(..)) trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.UQuasiQuote (Dom r) RangeStage) trfSplice :: TransformName n r => Located (HsSplice n) -> Trf (Ann AST.USplice (Dom r) RangeStage)
Language/Haskell/Tools/AST/FromGHC/Types.hs view
@@ -5,36 +5,29 @@ -- | Functions that convert the type-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.AST.FromGHC.Types where -import SrcLoc as GHC -import RdrName as GHC +import ApiAnnotation as GHC (AnnKeywordId(..)) import HsTypes as GHC -import ApiAnnotation as GHC -import FastString as GHC -import Type as GHC -import TyCon as GHC -import Outputable as GHC -import TysWiredIn (heqTyCon) import Id (mkVanillaGlobal) +import Outputable as GHC (Outputable(..), showSDocUnsafe) +import SrcLoc as GHC +import TyCon as GHC (TyCon(..)) +import TysWiredIn (heqTyCon) -import Control.Monad.Reader.Class -import Control.Applicative -import Control.Reference -import Data.Maybe -import Data.List (find) +import Control.Applicative (Applicative(..), (<$>), Alternative(..)) +import Control.Monad.Reader.Class (asks) +import Control.Reference ((^.)) import Data.Data (Data(..), toConstr) +import Data.List (find) +import Data.Maybe (Maybe(..), fromJust) -import Language.Haskell.Tools.AST.FromGHC.GHCUtils -import Language.Haskell.Tools.AST.FromGHC.Names -import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH -import Language.Haskell.Tools.AST.FromGHC.Kinds +import Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.AST.FromGHC.GHCUtils (GHCName(..), cleanHsType) +import Language.Haskell.Tools.AST.FromGHC.Kinds (trfKindSig, trfKind, trfPromoted') import Language.Haskell.Tools.AST.FromGHC.Monad +import Language.Haskell.Tools.AST.FromGHC.Names +import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH (trfSplice') import Language.Haskell.Tools.AST.FromGHC.Utils -import Language.Haskell.Tools.AST.FromGHC.Literals -import Language.Haskell.Tools.AST as AST - -import Debug.Trace - trfType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UType (Dom r) RangeStage) trfType typ = do othSplices <- asks typeSplices let RealSrcSpan loce = getLoc typ @@ -87,7 +80,7 @@ <*> trfKindSig (Just kind) trfCtx :: TransformName n r => Trf SrcLoc -> Located (HsContext n) -> Trf (AnnMaybeG AST.UContext (Dom r) RangeStage) -trfCtx sp (L l []) = nothing " " "" sp +trfCtx sp (L _ []) = nothing " " "" sp trfCtx _ (L l [L _ (HsParTy t)]) = makeJust <$> annLocNoSema (combineSrcSpans l <$> tokenLoc AnnDarrow) (AST.UContextMulti <$> trfAnnList ", " trfAssertion' [t]) @@ -111,7 +104,8 @@ HsIParamTy name t -> do loc <- tokenLoc AnnVal AST.UImplicitAssert <$> define (focusOn loc (trfImplicitName name)) <*> trfType t t -> error ("Illegal trf assertion: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")") - where (args, sp, base) = getArgs t + where (args, _, base) = getArgs t + getArgs :: HsType n -> ([LHsType n], Maybe SrcSpan, HsType n) getArgs (HsAppTy (L l ft) at) = case getArgs ft of (args, sp, base) -> (args++[at], sp <|> Just l, base) getArgs t = ([], Nothing, t)
Language/Haskell/Tools/AST/FromGHC/Utils.hs view
@@ -11,33 +11,47 @@ #-} module Language.Haskell.Tools.AST.FromGHC.Utils where -import ApiAnnotation -import SrcLoc +import ApiAnnotation (AnnKeywordId(..)) +import Avail (availNamesWithSelectors, availNames) +import BasicTypes (StringLiteral(..)) +import CoAxiom as GHC (CoAxiom(..)) +import CoreSyn as GHC (isOrphan) +import DynFlags (xopt) +import FamInstEnv as GHC (FamInst(..), famInstEnvElts) +import FastString (unpackFS, mkFastString) +import FieldLabel as GHC (FieldLbl(..)) import GHC -import Avail -import HscTypes -import BasicTypes import HsSyn -import Module +import HscTypes +import Id (idName) +import InstEnv as GHC (ClsInst(..), instanceDFunId, instEnvElts) +import Language.Haskell.TH.LanguageExtensions (Extension(..)) +import Module as GHC import Name -import NameSet -import Outputable -import FastString +import SrcLoc import Control.Monad.Reader -import Control.Reference hiding (element) -import Data.Maybe -import Data.IORef +import Control.Reference ((^.), (&)) +import Data.Char (isSpace) +import Data.Either (Either(..), rights, lefts) import Data.Function hiding ((&)) +import Data.IORef (readIORef) import Data.List -import Data.Char +import Data.Maybe import Language.Haskell.Tools.AST as AST -import Language.Haskell.Tools.AST.SemaInfoTypes -import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.GHCUtils +import Language.Haskell.Tools.AST.FromGHC.Monad import Language.Haskell.Tools.AST.FromGHC.SourceMap -import Debug.Trace +import Language.Haskell.Tools.AST.SemaInfoTypes as Sema +createModuleInfo :: ModSummary -> Trf (Sema.ModuleInfo GHC.Name) +createModuleInfo mod = do + let prelude = xopt ImplicitPrelude $ ms_hspp_opts mod + (_,preludeImports) <- if prelude then getImportedNames "Prelude" Nothing else return (ms_mod mod, []) + (insts, famInsts) <- if prelude then lift $ getOrphanAndFamInstances (Module baseUnitId (GHC.mkModuleName "Prelude")) + else return ([], []) + return $ mkModuleInfo (ms_mod mod) (case ms_hsc_src mod of HsSrcFile -> False; _ -> True) preludeImports insts famInsts + -- | Creates a semantic information for a name createNameInfo :: n -> Trf (NameInfo n) createNameInfo name = do locals <- asks localsInScope @@ -66,29 +80,53 @@ -- | Adds semantic information to an impord declaration. See ImportInfo. createImportData :: (GHCName r, HsHasName n) => GHC.ImportDecl n -> Trf (ImportInfo r) -createImportData (GHC.ImportDecl src name pkg isSrc isSafe isQual isImpl declAs declHiding) = - do (mod,importedNames) <- getImportedNames (Module.moduleNameString $ unLoc name) (fmap (unpackFS . sl_fs) pkg) +createImportData (GHC.ImportDecl _ name pkg _ _ _ _ _ declHiding) = + do (mod,importedNames) <- getImportedNames (GHC.moduleNameString $ unLoc name) (fmap (unpackFS . sl_fs) pkg) names <- liftGhc $ filterM (checkImportVisible declHiding) importedNames lookedUpNames <- liftGhc $ mapM (getFromNameUsing getTopLevelId) names lookedUpImported <- liftGhc $ mapM (getFromNameUsing getTopLevelId) importedNames - return $ mkImportInfo mod (catMaybes lookedUpImported) (catMaybes lookedUpNames) + (insts,famInsts) <- lift $ getOrphanAndFamInstances mod + return $ mkImportInfo mod (catMaybes lookedUpImported) (catMaybes lookedUpNames) insts famInsts +getOrphanAndFamInstances :: Module -> Ghc ([ClsInst], [FamInst]) +getOrphanAndFamInstances mod = do + env <- getSession + eps <- liftIO (readIORef (hsc_EPS env)) + let ifc = lookupIfaceByModule (hsc_dflags env) (hsc_HPT env) (eps_PIT eps) mod + hp = lookupHptByModule (hsc_HPT env) mod + uses = catMaybes $ map getModule $ maybe [] (\ifc -> dep_orphs (mi_deps ifc) `union` dep_finsts (mi_deps ifc)) ifc + getModule mod = if moduleUnitId mod == mainUnitId + then fmap Right $ lookupHptByModule (hsc_HPT env) mod + else fmap Left $ lookupIfaceByModule (hsc_dflags env) (hsc_HPT env) (eps_PIT eps) mod + usedMods = lefts uses + usedDetails = map hm_details (maybeToList hp ++ rights uses) + hptInstances = filter (isOrphan . is_orphan) $ concatMap md_insts usedDetails + hptFamilyInstances = concatMap md_fam_insts usedDetails + allInstances = instEnvElts (eps_inst_env eps) + relevantInstances = hptInstances ++ filter ((\n -> nameModule n `elem` (mod : map mi_module usedMods)) . idName . instanceDFunId) (filter (isOrphan . is_orphan) allInstances) + allFamilyInstances = famInstEnvElts (eps_fam_inst_env eps) + relevantFamilyInstances = hptFamilyInstances ++ filter ((\n -> nameModule n `elem` (mod : map mi_module usedMods)) . co_ax_name . fi_axiom) allFamilyInstances + return (relevantInstances, relevantFamilyInstances) + + -- | Get names that are imported from a given import getImportedNames :: String -> Maybe String -> Trf (GHC.Module, [GHC.Name]) getImportedNames name pkg = liftGhc $ do + hpt <- hsc_HPT <$> getSession eps <- getSession >>= liftIO . readIORef . hsc_EPS mod <- findModule (mkModuleName name) (fmap mkFastString pkg) -- load exported names from interface file let ifaceNames = concatMap availNames $ maybe [] mi_exports $ flip lookupModuleEnv mod $ eps_PIT eps - loadedNames <- maybe [] modInfoExports <$> getModuleInfo mod - return (mod, ifaceNames ++ loadedNames) + let homeExports = maybe [] (md_exports . hm_details) (lookupHptByModule hpt mod) + mi <- getModuleInfo mod + return (mod, ifaceNames ++ concatMap availNamesWithSelectors homeExports) -- | Check is a given name is imported from an import with given import specification. checkImportVisible :: (HsHasName name, GhcMonad m) => Maybe (Bool, Located [LIE name]) -> GHC.Name -> m Bool checkImportVisible (Just (isHiding, specs)) name - | isHiding = not . or @[] <$> mapM (`ieSpecMatches` name) (map unLoc (unLoc specs)) + | isHiding = not . or @[] <$> mapM (`ieSpecMatches` name) (map unLoc (unLoc specs)) | otherwise = or @[] <$> mapM (`ieSpecMatches` name) (map unLoc (unLoc specs)) checkImportVisible _ _ = return True @@ -96,13 +134,18 @@ ieSpecMatches (hsGetNames . HsSyn.ieName -> [n]) name | n == name = return True | isTyConName n - = (\case Just (ATyCon tc) -> name `elem` map getName (tyConDataCons tc)) - <$> lookupName n + = do entity <- lookupName n + return $ case entity of Just (ATyCon tc) + | Just cls <- tyConClass_maybe tc + -> name `elem` map getName (classMethods cls) + | otherwise -> name `elem` concatMap (\dc -> getName dc : map flSelector (dataConFieldLabels dc)) + (tyConDataCons tc) + _ -> False ieSpecMatches _ _ = return False noSemaInfo :: src -> NodeInfo NoSemanticInfo src noSemaInfo = NodeInfo mkNoSemanticInfo - + -- | Creates a place for a missing node with a default location nothing :: String -> String -> Trf SrcLoc -> Trf (AnnMaybeG e (Dom n) RangeStage) nothing bef aft pos = annNothing . noSemaInfo . OptionalPos bef aft <$> pos @@ -296,7 +339,7 @@ = do spanFirst <- tokenLoc keyw spanRest <- tokensLoc' rest (mkSrcSpan (srcSpanEnd spanFirst) (srcSpanEnd r)) return (combineSrcSpans spanFirst spanRest) - tokensLoc' [] r = pure noSrcSpan + tokensLoc' [] _ = pure noSrcSpan -- | Searches for a token and retrieves its location anywhere uniqueTokenAnywhere :: AnnKeywordId -> Trf SrcSpan @@ -325,7 +368,7 @@ -- | Update column information in a source location updateCol :: (Int -> Int) -> SrcLoc -> SrcLoc -updateCol f loc@(UnhelpfulLoc _) = loc +updateCol _ loc@(UnhelpfulLoc _) = loc updateCol f (RealSrcLoc loc) = mkSrcLoc (srcLocFile loc) (srcLocLine loc) (f $ srcLocCol loc) -- | Update the start of the src span @@ -348,11 +391,15 @@ orderAnnList :: AnnListG e (Dom n) RangeStage -> AnnListG e (Dom n) RangeStage orderAnnList (AnnListG a ls) = AnnListG a (orderDefs ls) +-- | Only keeps one of the elements that are on the same source location +removeDuplicates :: [Located e] -> [Located e] +removeDuplicates (fst:rest) = fst : removeDuplicates (filter ((/= getLoc fst) . getLoc) rest) +removeDuplicates [] = [] -- | Transform a list of definitions where the defined names are in scope for subsequent definitions trfScopedSequence :: HsHasName d => (d -> Trf e) -> [d] -> Trf [e] trfScopedSequence f (def:rest) = (:) <$> f def <*> addToScope def (trfScopedSequence f rest) -trfScopedSequence f [] = pure [] +trfScopedSequence _ [] = pure [] -- | Splits a given string at whitespaces while calculating the source location of the fragments splitLocated :: Located String -> [Located String] @@ -364,5 +411,5 @@ splitLocated' (c:rest) currLoc (Just (startLoc, str)) = splitLocated' rest (advanceSrcLoc currLoc c) (Just (startLoc, c:str)) splitLocated' (c:rest) currLoc Nothing = splitLocated' rest (advanceSrcLoc currLoc c) (Just (currLoc, [c])) splitLocated' [] currLoc (Just (startLoc, str)) = [L (RealSrcSpan $ mkRealSrcSpan startLoc currLoc) (reverse str)] - splitLocated' [] currLoc Nothing = [] - + splitLocated' [] _ Nothing = [] +splitLocated _ = error "splitLocated: unhelpful span given"
haskell-tools-backend-ghc.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-backend-ghc -version: 0.4.1.1 +version: 0.4.1.2 synopsis: Creating the Haskell-Tools AST from GHC's representations description: This package collects information from various representations of a Haskell program in GHC. Basically GHC provides us with the parsed, the renamed and the type checked representation of the program, if it was type correct. Each version contains different information. For example, the renamed AST contains the unique names of the definitions, however, template haskell splices are already resolved and thus missing from that version of the AST. To get the final representation we perform a transformation on the parsed and renamed representation, and then use the type checked one to look up the types of the names. The whole transformation is defined in the `Modules` module. Other modules define the functions that convert elements of the GHC AST to our AST. homepage: https://github.com/nboldi/haskell-tools