haskell-tools-backend-ghc 0.9.0.0 → 1.0.0.0
raw patch · 17 files changed
+338/−247 lines, 17 filesdep ~basedep ~ghcdep ~ghc-boot-th
Dependency ranges changed: base, ghc, ghc-boot-th, haskell-tools-ast, template-haskell
Files
- Language/Haskell/Tools/BackendGHC.hs +6/−3
- Language/Haskell/Tools/BackendGHC/AddTypeInfo.hs +21/−17
- Language/Haskell/Tools/BackendGHC/Binds.hs +21/−16
- Language/Haskell/Tools/BackendGHC/Decls.hs +68/−57
- Language/Haskell/Tools/BackendGHC/Exprs.hs +20/−16
- Language/Haskell/Tools/BackendGHC/GHCUtils.hs +22/−21
- Language/Haskell/Tools/BackendGHC/Kinds.hs +5/−7
- Language/Haskell/Tools/BackendGHC/Literals.hs +1/−1
- Language/Haskell/Tools/BackendGHC/Modules.hs +51/−33
- Language/Haskell/Tools/BackendGHC/Monad.hs +16/−7
- Language/Haskell/Tools/BackendGHC/Names.hs +3/−13
- Language/Haskell/Tools/BackendGHC/Patterns.hs +11/−6
- Language/Haskell/Tools/BackendGHC/Stmts.hs +3/−6
- Language/Haskell/Tools/BackendGHC/TH.hs +6/−5
- Language/Haskell/Tools/BackendGHC/Types.hs +6/−9
- Language/Haskell/Tools/BackendGHC/Utils.hs +72/−24
- haskell-tools-backend-ghc.cabal +6/−6
Language/Haskell/Tools/BackendGHC.hs view
@@ -1,9 +1,12 @@ -- | The FromGHC module provides a way to transform the GHC AST into our AST. This transformation is done in -- the Ghc monad. The conversion can be performed from the Parsed and the Renamed GHC AST. If the renamed AST -- is given, additional semantic information is looked up while traversing the AST. -module Language.Haskell.Tools.BackendGHC - ( trfModule, trfModuleRename, addTypeInfos, runTrf) where +module Language.Haskell.Tools.BackendGHC + ( trfModule, trfModuleRename, addTypeInfos, runTrf + , SpliceInsertionProblem(..), ConvertionProblem(..) + ) where import Language.Haskell.Tools.BackendGHC.AddTypeInfo (addTypeInfos) import Language.Haskell.Tools.BackendGHC.Modules (trfModule, trfModuleRename) -import Language.Haskell.Tools.BackendGHC.Monad (runTrf) +import Language.Haskell.Tools.BackendGHC.Monad (runTrf, SpliceInsertionProblem(..)) +import Language.Haskell.Tools.BackendGHC.Utils (ConvertionProblem(..))
Language/Haskell/Tools/BackendGHC/AddTypeInfo.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE TupleSections - , LambdaCase - , ScopedTypeVariables - #-} +{-# LANGUAGE LambdaCase, ScopedTypeVariables, TupleSections #-} module Language.Haskell.Tools.BackendGHC.AddTypeInfo (addTypeInfos) where import Bag as GHC (bagToList) @@ -15,11 +12,12 @@ import TcEvidence as GHC (EvBind(..), TcEvBinds(..)) import Type as GHC (Type, mkTyVarTy, mkTyConTy) import TysWiredIn as GHC (starKindTyCon) -import UniqFM as GHC (eltsUFM) +import UniqDFM as GHC (eltsUDFM) import UniqSupply as GHC (uniqFromSupply, mkSplitUniqSupply) import Var as GHC (Var(..)) import Control.Applicative (Applicative(..), (<$>), Alternative(..)) +import Control.Exception (evaluate, throw) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State import Control.Monad.Trans.Class (MonadTrans(..)) @@ -29,18 +27,20 @@ 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 (mkCNameInfo) import Language.Haskell.Tools.BackendGHC.GHCUtils (getTopLevelId) +import Language.Haskell.Tools.BackendGHC.Utils (ConvertionProblem(..), forceElements, convProblem) addTypeInfos :: LHsBinds Id -> Ann AST.UModule (Dom GHC.Name) RangeStage -> Ghc (Ann AST.UModule IdDom RangeStage) addTypeInfos bnds mod = do ut <- liftIO mkUnknownType let getType = getType' ut fixities <- getFixities + -- evaluates fixities to normal form before going on, otherwise the reference to session would be kept + liftIO $ evaluate (forceElements fixities) let createCName sc def id = mkCNameInfo sc def id fixity - where fixity = if any (any ((getOccName id ==) . getOccName . (^. _1))) (init sc) + where fixity = if any (any ((getOccName id ==) . getOccName . (^. _1))) (drop 1 sc) then Nothing else fmap (snd . snd) $ List.find (\(mod,(occ,_)) -> Just mod == (nameModule_maybe $ varName id) && occ == getOccName id) fixities evalStateT (semaTraverse @@ -50,11 +50,11 @@ (Just l@(RealSrcSpan loc), _) -> case Map.lookup l locMapping of Just id -> return $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) id - _ -> do (none,rest) <- gets (break ((\(RealSrcSpan sp) -> sp `containsSpan` loc) . fst)) - case rest of [] -> error $ "Ambiguous or implicit name missing, at: " ++ show loc + _ -> do (none,rest) <- gets (break ((\case (RealSrcSpan sp) -> sp `containsSpan` loc) . fst)) + case rest of [] -> throw $ ConvertionProblem (RealSrcSpan loc) "Ambiguous or implicit name missing" ((_,id):more) -> do put (none ++ more) return $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) id - _ -> error "addTypeInfos: Cannot access a the semantics of a name.") + _ -> convProblem "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 @@ -72,7 +72,7 @@ getFixities = do env <- getSession pit <- liftIO $ eps_PIT <$> hscEPS env let hpt = hsc_HPT env - ifaces = moduleEnvElts pit ++ map hm_iface (eltsUFM hpt) + ifaces = moduleEnvElts pit ++ map hm_iface (eltsUDFM hpt) return $ concatMap (\mi -> map (mi_module mi, ) $ mi_fixities mi) ifaces extractExprIds :: LHsBinds Id -> [Located Id] @@ -83,15 +83,19 @@ ) . concatMap universeBi . bagToList extractSigIds :: LHsBinds Id -> [(SrcSpan,Id)] -extractSigIds = concat . map (\case L l bs@(AbsBindsSig {} :: HsBind Id) -> map (l,) $ getImplVars (abs_sig_ev_bind bs) - _ -> [] - ) . concatMap universeBi . bagToList +extractSigIds = filter (isGoodSrcSpan . fst) + . concat + . map (\case L l bs@(AbsBindsSig {} :: HsBind Id) -> map (l,) $ getImplVars (abs_sig_ev_bind bs) + _ -> [] ) + . 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 (IPBind (Right id) _) -> Just (l,id) - _ -> Nothing - ) . concatMap universeBi . bagToList +extractSigBindIds = filter (isGoodSrcSpan . fst) + . catMaybes + . map (\case L l (IPBind (Right id) _) -> Just (l,id) + _ -> Nothing ) + . concatMap universeBi . bagToList
Language/Haskell/Tools/BackendGHC/Binds.hs view
@@ -1,25 +1,23 @@-{-# LANGUAGE LambdaCase - , ViewPatterns - #-} +{-# LANGUAGE LambdaCase, ViewPatterns #-} -- | 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.BackendGHC.Binds where import ApiAnnotation as GHC (AnnKeywordId(..)) import Bag as GHC (bagToList) -import BasicTypes as GHC (FixityDirection(..), Fixity(..)) import BasicTypes as GHC import HsBinds as GHC import HsExpr as GHC import HsPat as GHC (LPat) -import HsTypes as GHC (HsWildCardBndrs(..), HsImplicitBndrs(..)) +import HsTypes as GHC (SrcStrictness(..), HsWildCardBndrs(..), HsImplicitBndrs(..)) import Name as GHC (isSymOcc) +import PlaceHolder as GHC (NameOrRdrName) import SrcLoc as GHC import Control.Monad.Reader (Monad(..), mapM, asks) import Data.List import Language.Haskell.Tools.BackendGHC.Exprs (trfExpr) -import Language.Haskell.Tools.BackendGHC.GHCUtils (occName) +import Language.Haskell.Tools.BackendGHC.GHCUtils (occName, fromSrcText) import Language.Haskell.Tools.BackendGHC.Monad import Language.Haskell.Tools.BackendGHC.Names import Language.Haskell.Tools.BackendGHC.Patterns (trfPattern) @@ -33,7 +31,14 @@ trfBind = trfLocNoSema trfBind' trfBind' :: TransformName n r => HsBind n -> Trf (AST.UValueBind (Dom r) RangeStage) --- a value binding (not a function) +-- A value binding with a strcitness annotation +trfBind' (FunBind { fun_id = id, fun_matches = MG { mg_alts = L _ [L _ (Match { m_ctxt = FunRhs { mc_strictness = SrcStrict }, m_pats = [], m_grhss = GRHSs [L _ (GRHS [] expr)] (L _ locals) })]} }) + = do bangLoc <- focusBeforeLoc (srcSpanStart $ getLoc id) $ tokenLoc AnnBang + AST.USimpleBind <$> annLocNoSema (pure $ combineSrcSpans bangLoc (getLoc id)) + (AST.UBangPat <$> copyAnnot AST.UVarPat (define $ trfName id)) + <*> addEmptyScope (addToScope locals (annLocNoSema (combineSrcSpans (getLoc expr) <$> tokenLoc AnnEqual) (AST.UUnguardedRhs <$> trfExpr expr))) + <*> addEmptyScope (trfWhereLocalBinds (getLoc expr) locals) +-- A value binding (not a function) 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) <*> addEmptyScope (addToScope locals (annLocNoSema (combineSrcSpans (getLoc expr) <$> tokenLoc AnnEqual) (AST.UUnguardedRhs <$> trfExpr expr))) @@ -44,7 +49,7 @@ = AST.USimpleBind <$> trfPattern pat <*> addEmptyScope (addToScope locals (trfRhss rhs)) <*> addEmptyScope (trfWhereLocalBinds (collectLocs rhs) locals) -trfBind' (PatSynBind _) = error "Pattern synonym bindings should be recognized on the declaration level" +trfBind' (PatSynBind _) = convertionProblem "Pattern synonym bindings should be recognized on the declaration level" trfBind' b = unhandledElement "binding" b trfMatch :: TransformName n r => n -> Located (Match n (LHsExpr n)) -> Trf (Ann AST.UMatch (Dom r) RangeStage) @@ -57,7 +62,7 @@ <*> addToScope pats (addToScope locBinds (trfRhss rhss)) <*> addToScope pats (trfWhereLocalBinds (collectLocs rhss) locBinds) -trfMatchLhs :: TransformName n r => n -> MatchFixity n -> [LPat n] -> Trf (Ann AST.UMatchLhs (Dom r) RangeStage) +trfMatchLhs :: TransformName n r => n -> HsMatchContext (NameOrRdrName n) -> [LPat n] -> Trf (Ann AST.UMatchLhs (Dom r) RangeStage) trfMatchLhs name fb pats = do implicitIdLoc <- mkSrcSpan <$> atTheStart <*> atTheStart parenOpLoc <- tokensLoc [AnnOpenP, AnnVal, AnnCloseP] @@ -70,9 +75,9 @@ -- a paren, so we need to check that it is actually what we seek closeLoc <- srcSpanStart <$> (combineSrcSpans <$> tokenLoc AnnEqual <*> tokenLoc AnnVbar) args <- mapM trfPattern pats - let (n, isInfix) = case fb of NonFunBindMatch -> let token = if isSymOcc (occName name) && isGoodSrcSpan infixLoc then infixLoc else implicitIdLoc - in (L token name, length pats > 0 && srcSpanStart token >= srcSpanEnd (getLoc (pats !! 0))) - FunBindMatch n inf -> (n, inf) + let (n, isInfix) = case fb of FunRhs n inf _ -> (n, inf == Infix) + _ -> let token = if isSymOcc (occName name) && isGoodSrcSpan infixLoc then infixLoc else implicitIdLoc + in (L token name, length pats > 0 && srcSpanStart token >= srcSpanEnd (getLoc (pats !! 0))) annLocNoSema (mkSrcSpan <$> atTheStart <*> (pure closeLoc)) $ case (args, isInfix) of (left:right:rest, True) -> AST.UInfixLhs left <$> define (trfOperator n) <*> pure right <*> makeList " " (pure closeLoc) (pure rest) @@ -130,7 +135,7 @@ <$> (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" + IPBind (Right _) _ -> convertionProblem "trfIpBind: called on typechecked AST" trfLocalSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.ULocalBind (Dom r) RangeStage) trfLocalSig = trfLocNoSema $ \case @@ -144,7 +149,7 @@ 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) + = defineTypeVars $ AST.UTypeSignature <$> makeNonemptyList ", " (mapM trfName names) <*> trfType (hsib_body $ hswc_body typ) trfTypeSig' ts = unhandledElement "type signature" ts trfFixitySig :: TransformName n r => FixitySig n -> Trf (AST.UFixitySignature (Dom r) RangeStage) @@ -166,7 +171,7 @@ trfInlinePragma name (InlinePragma _ Inlinable _ phase _) = annContNoSema (AST.UInlinablePragma <$> trfPhase (pure $ srcSpanStart $ getLoc name) phase <*> trfName name) trfInlinePragma name (InlinePragma _ NoInline _ _ _) = annContNoSema (AST.UNoInlinePragma <$> trfName name) -trfInlinePragma name (InlinePragma src Inline _ phase cl) +trfInlinePragma name (InlinePragma (fromSrcText -> src) Inline _ phase cl) = annContNoSema $ do rng <- asks contRange let parts = map getLoc $ splitLocated (L rng src) AST.UInlinePragma <$> trfConlike parts cl @@ -188,6 +193,6 @@ trfConlike :: [SrcSpan] -> RuleMatchInfo -> Trf (AnnMaybeG AST.UConlikeAnnot (Dom r) RangeStage) trfConlike parts ConLike | length parts > 2 = makeJust <$> annLocNoSema (pure $ parts !! 2) (pure AST.UConlikeAnnot) - | otherwise = error $ "trfConlike: expected 3 parts, got: " ++ show parts + | otherwise = convertionProblem $ "trfConlike: expected 3 parts, got: " ++ show parts trfConlike (_:inlTok:_) FunLike = nothing " " "" (pure $ srcSpanEnd inlTok) trfConlike (combTok:_) FunLike = nothing " " "" (pure $ srcSpanEnd combTok)
Language/Haskell/Tools/BackendGHC/Decls.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE LambdaCase - , ViewPatterns - , ScopedTypeVariables - #-} +{-# LANGUAGE LambdaCase, ScopedTypeVariables, ViewPatterns #-} -- | Functions that convert the declarations of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Decls where @@ -38,13 +35,13 @@ 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 (nameInfo) +import Language.Haskell.Tools.AST.SemaInfoTypes as AST (nameInfo, mkNoSemanticInfo) trfDecls :: TransformName n r => [LHsDecl n] -> Trf (AnnListG AST.UDecl (Dom r) RangeStage) 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 _) +trfDeclsGroup g@(HsGroup vals splices tycls derivs fixities defaults foreigns warns anns rules vects _) = do rdrSpls <- asks declSplices -- now we don't want to rename the splices, just interested in their locations to -- filter out the declarations that are generated from them let (sigs, bagToList -> binds) = getBindsAndSigs vals @@ -54,7 +51,6 @@ ++ (map (fmap ValD) binds) ++ (map (fmap SigD) sigs) ++ (map (fmap TyClD) (concat $ map group_tyclds tycls)) - ++ (map (fmap InstD) insts) ++ (map (fmap DerivD) derivs) ++ (map (fmap (SigD . FixSig)) (mergeFixityDefs fixities)) ++ (map (fmap DefD) defaults) @@ -63,6 +59,7 @@ ++ (map (fmap AnnD) anns) ++ (map (fmap RuleD) rules) ++ (map (fmap VectD) vects) + ++ (map (fmap InstD) (hsGroupInstDecls g)) -- Declarations generated from TH should only be in scope after the splice. let (genNames, sourceNames) = partition (\d -> any (\spl -> getLoc spl `containsRealSpan` getLoc d) rdrSpls) alldecls addToCurrentScope sourceNames $ do @@ -96,37 +93,37 @@ 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" + mergeSplice _ (L (UnhelpfulSpan {}) _) = convProblem "mergeSplice: no real span" getDeclsToInsert :: Trf [Ann AST.UDecl (Dom r) RangeStage] getDeclsToInsert = do decls <- asks declsToInsert allLocals <- asks localsInScope case allLocals of locals:_ -> liftGhc $ mapM (loadIdsForDecls (map (^. _1) locals)) decls - [] -> error "getDeclsToInsert: empty scope" + [] -> convertionProblem "getDeclsToInsert: empty scope" where loadIdsForDecls :: [GHC.Name] -> Ann AST.UDecl (Dom RdrName) RangeStage -> GHC.Ghc (Ann AST.UDecl (Dom r) RangeStage) loadIdsForDecls locals = AST.semaTraverse $ AST.SemaTrf (AST.nameInfo !~ findName) pure (traverse findName) pure pure pure - where findName rdr = pure $ fromGHCName $ fromMaybe (error $ "Data definition name not found: " ++ showSDocUnsafe (ppr rdr) - ++ ", locals: " ++ (concat $ intersperse ", " $ map (showSDocUnsafe . ppr) locals)) + where findName rdr = pure $ fromGHCName $ fromMaybe (convProblem $ "Data definition name not found: " ++ showSDocUnsafe (ppr rdr) + ++ ", locals: " ++ (concat $ intersperse ", " $ map (showSDocUnsafe . ppr) locals)) $ find ((occNameString (rdrNameOcc rdr) ==) . occNameString . nameOccName) locals trfDecl :: TransformName n r => Located (HsDecl n) -> Trf (Ann AST.UDecl (Dom r) RangeStage) trfDecl = trfLocNoSema $ \case - TyClD (FamDecl (FamilyDecl (ClosedTypeFamily typeEqs) name tyVars kindSig inj)) + TyClD (FamDecl (FamilyDecl (ClosedTypeFamily typeEqs) name tyVars _ kindSig inj)) -> AST.UClosedTypeFamilyDecl <$> focusAfter AnnType (createDeclHead name tyVars) <*> trfFamilyResultSig kindSig inj <*> trfTypeEqs typeEqs TyClD (FamDecl fd) -> AST.UTypeFamilyDecl <$> annContNoSema (trfTypeFam' fd) - TyClD (SynDecl name vars rhs _) + TyClD (SynDecl name vars _ rhs _) -> AST.UTypeDecl <$> between AnnType AnnEqual (createDeclHead name vars) <*> trfType rhs - TyClD (DataDecl name vars (HsDataDefn nd ctx _ kind cons derivs) _ _) + TyClD (DataDecl name vars _ (HsDataDefn nd ctx _ kind cons derivs) _ _) -> do let ctxTok = case nd of DataType -> AnnData NewType -> AnnNewtype consLoc = focusBeforeIfPresent AnnDeriving atTheEnd 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 _ _) + TyClD (ClassDecl ctx name vars _ funDeps sigs defs typeFuns typeFunDefs _ _) -> AST.UClassDecl <$> trfCtx (after AnnClass) ctx <*> betweenIfPresent AnnClass AnnWhere (createDeclHead name vars) <*> trfFunDeps funDeps @@ -135,25 +132,25 @@ -> AST.UInstDecl <$> trfMaybeDefault " " "" trfOverlap (after AnnInstance) overlap <*> trfInstanceRule (hsib_body typ) <*> trfInstBody binds sigs typefam datafam - InstD (DataFamInstD (DataFamInstDecl con pats (HsDataDefn nd _ _ _ cons derivs) _)) + InstD (DataFamInstD (DataFamInstDecl con pats _ (HsDataDefn nd _ _ _ cons derivs) _)) | all ((\case ConDeclH98{} -> True; _ -> False) . unLoc) cons -> AST.UDataInstDecl <$> trfDataKeyword nd <*> (focusAfter AnnInstance . focusBeforeIfPresent AnnEqual . focusBeforeIfPresent AnnDeriving) (makeInstanceRuleTyVars con pats) -- the location is needed when there is no = sign <*> makeListBefore " = " " | " (pure $ srcSpanStart $ foldLocs $ getLoc con : map getLoc (hsib_body pats)) (mapM trfConDecl cons) - <*> trfMaybe "" "" trfDerivings derivs - InstD (DataFamInstD (DataFamInstDecl con pats (HsDataDefn nd _ _ kind cons _) _)) + <*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs)) + InstD (DataFamInstD (DataFamInstDecl con pats _ (HsDataDefn nd _ _ kind cons _) _)) -> AST.UGDataInstDecl <$> trfDataKeyword nd <*> (focusAfter AnnInstance . focusBeforeIfPresent AnnWhere) (makeInstanceRuleTyVars con pats) <*> focusBefore AnnWhere (trfKindSig kind) <*> makeIndentedListBefore " where " atTheEnd (mapM trfGADTConDecl cons) - InstD (TyFamInstD (TyFamInstDecl (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 - DerivD (DerivDecl t overlap) -> AST.UDerivDecl <$> trfMaybeDefault " " "" trfOverlap (after AnnInstance) overlap <*> trfInstanceRule (hsib_body t) + DerivD (DerivDecl t strat overlap) -> AST.UDerivDecl <$> trfDerivingStrategy strat <*> trfMaybeDefault " " "" trfOverlap (after AnnInstance) overlap <*> trfInstanceRule (hsib_body t) RuleD (HsRules _ rules) -> AST.UPragmaDecl <$> annContNoSema (AST.URulePragma <$> makeIndentedList (before AnnClose) (mapM trfRewriteRule rules)) RoleAnnotD (RoleAnnotDecl name roles) -> AST.URoleDecl <$> trfQualifiedName False name <*> makeList " " atTheEnd (mapM trfRole roles) DefD (DefaultDecl types) -> AST.UDefaultDecl <$> makeList "," (after AnnOpenP) (mapM trfType types) @@ -177,24 +174,24 @@ trfGADT :: TransformName n r => NewOrData -> Located n -> LHsQTyVars n -> Located (HsContext n) -> Maybe (Located (HsKind n)) -> [Located (ConDecl n)] - -> Maybe (Located [LHsSigType n]) -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.UDecl (Dom r) RangeStage) + -> Located [LHsDerivingClause n] -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.UDecl (Dom r) RangeStage) trfGADT nd name vars ctx kind cons derivs ctxTok consLoc = AST.UGDataDecl <$> trfDataKeyword nd <*> trfCtx (after ctxTok) ctx <*> betweenIfPresent ctxTok AnnEqual (createDeclHead name vars) <*> focusBefore AnnWhere (trfKindSig kind) <*> makeIndentedListBefore " where " consLoc (mapM trfGADTConDecl cons) - <*> trfMaybe "" "" trfDerivings derivs + <*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs)) trfDataDef :: TransformName n r => NewOrData -> Located n -> LHsQTyVars n -> Located (HsContext n) - -> [Located (ConDecl n)] -> Maybe (Located [LHsSigType n]) + -> [Located (ConDecl n)] -> Located [LHsDerivingClause n] -> AnnKeywordId -> Trf SrcLoc -> Trf (AST.UDecl (Dom r) RangeStage) trfDataDef nd name vars ctx cons derivs ctxTok consLoc = AST.UDataDecl <$> trfDataKeyword nd <*> trfCtx (after ctxTok) ctx <*> betweenIfPresent ctxTok AnnEqual (createDeclHead name vars) <*> makeListBefore "=" " | " consLoc (mapM trfConDecl cons) - <*> trfMaybe "" "" trfDerivings derivs + <*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs)) trfVal :: TransformName n r => HsBindLR n n -> Trf (AST.UDecl (Dom r) RangeStage) trfVal (PatSynBind psb) = AST.UPatternSynonymDecl <$> annContNoSema (trfPatternSynonym psb) @@ -203,12 +200,15 @@ trfSig :: TransformName n r => Sig n -> Trf (AST.UDecl (Dom r) RangeStage) trfSig (ts @ (TypeSig {})) = AST.UTypeSigDecl <$> defineTypeVars (annContNoSema $ trfTypeSig' ts) trfSig (FixSig fs) = AST.UFixityDecl <$> (annContNoSema $ trfFixitySig fs) -trfSig (PatSynSig id typ) - = AST.UPatTypeSigDecl <$> annContNoSema (AST.UPatternTypeSignature <$> trfName id <*> trfType (hsib_body typ)) +trfSig (PatSynSig ids typ) + = AST.UPatTypeSigDecl <$> annContNoSema (AST.UPatternTypeSignature <$> trfAnnList ", " trfName' ids <*> trfType (hsib_body typ)) trfSig (InlineSig name prag) = AST.UPragmaDecl <$> annContNoSema (AST.UInlinePragmaDecl <$> trfInlinePragma name prag) trfSig (SpecSig name (map hsib_body -> types) (inl_act -> phase)) = AST.UPragmaDecl <$> annContNoSema (AST.USpecializeDecl <$> trfSpecializePragma name types phase) +trfSig (CompleteMatchSig _ names typeConstraint) + = AST.UPragmaDecl <$> annContNoSema (AST.UCompletePragma <$> trfAnnList ", " trfName' (unLoc names) + <*> trfMaybe " :: " "" trfName typeConstraint) trfSig s = unhandledElement "signature" s trfSpecializePragma :: TransformName n r @@ -269,11 +269,20 @@ trfFieldDecl' :: TransformName n r => ConDeclField n -> Trf (AST.UFieldDecl (Dom r) RangeStage) trfFieldDecl' (ConDeclField names typ _) = AST.UFieldDecl <$> (define $ nonemptyAnnList <$> mapM (trfName . getFieldOccName) names) <*> trfType typ -trfDerivings :: TransformName n r => Located [LHsSigType n] -> Trf (Ann AST.UDeriving (Dom r) RangeStage) +trfDerivings :: TransformName n r => Located (HsDerivingClause n) -> Trf (Ann AST.UDeriving (Dom r) RangeStage) trfDerivings = trfLocNoSema $ \case - [hsib_body -> typ@(unLoc -> HsTyVar {})] -> AST.UDerivingOne <$> trfInstanceHead typ - derivs -> AST.UDerivings <$> trfAnnList ", " trfInstanceHead' (map hsib_body derivs) + HsDerivingClause strat (unLoc->[hsib_body -> typ@(unLoc -> HsTyVar {})]) + -> AST.UDerivingOne <$> trfDerivingStrategy strat <*> trfInstanceHead typ + HsDerivingClause strat derivs + -> AST.UDerivings <$> trfDerivingStrategy strat <*> focusOn (getLoc derivs) (trfAnnList ", " trfInstanceHead' (map hsib_body (unLoc derivs))) +trfDerivingStrategy :: Maybe (Located DerivStrategy) -> Trf (AnnMaybeG AST.UDeriveStrategy (Dom r) RangeStage) +trfDerivingStrategy = trfMaybeDefault " " "" + (trfLocNoSema $ \case StockStrategy -> return AST.UStockStrategy + AnyclassStrategy -> return AST.UAnyClassStrategy + NewtypeStrategy -> return AST.UNewtypeStrategy) + atTheStart + trfInstanceRule :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage) trfInstanceRule = trfLocNoSema (trfInstanceRule' . cleanHsType) @@ -286,7 +295,7 @@ <*> trfCtx atTheStart ctx <*> trfInstanceHead typ trfInstanceRule' (HsParTy typ) = instanceHead $ annContNoSema (AST.UInstanceHeadParen <$> trfInstanceHead typ) -trfInstanceRule' (HsTyVar tv) = instanceHead $ annContNoSema (AST.UInstanceHeadCon <$> trfName tv) +trfInstanceRule' (HsTyVar _ tv) = instanceHead $ annContNoSema (AST.UInstanceHeadCon <$> trfName tv) trfInstanceRule' (HsAppTy t1 t2) = instanceHead $ annContNoSema (AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2) trfInstanceRule' (HsOpTy t1 op t2) = instanceHead $ annContNoSema (AST.UInstanceHeadApp <$> annLocNoSema (pure $ getLoc t1 `combineSrcSpans` getLoc op) (AST.UInstanceHeadInfix <$> trfType t1 <*> trfOperator op) <*> trfType t2) trfInstanceRule' t = unhandledElement "instance rule" t @@ -319,7 +328,7 @@ trfInstanceHead' :: TransformName n r => HsType n -> Trf (AST.UInstanceHead (Dom r) RangeStage) trfInstanceHead' = trfInstanceHead'' . cleanHsType where trfInstanceHead'' (HsForAllTy [] (unLoc -> t)) = trfInstanceHead' t - trfInstanceHead'' (HsTyVar tv) = AST.UInstanceHeadCon <$> trfName tv + trfInstanceHead'' (HsTyVar _ tv) = AST.UInstanceHeadCon <$> trfName tv trfInstanceHead'' (HsAppTy t1 t2) = AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2 trfInstanceHead'' (HsParTy typ) = AST.UInstanceHeadParen <$> trfInstanceHead typ trfInstanceHead'' (HsOpTy t1 op t2) @@ -331,11 +340,11 @@ trfTypeEqs :: TransformName n r => Maybe [Located (TyFamInstEqn n)] -> Trf (AnnListG AST.UTypeEqn (Dom r) RangeStage) trfTypeEqs eqs = do toks <- tokensAfter AnnWhere - case toks of [] -> error "trfTypeEqs: no where found after closed type family" + case toks of [] -> convertionProblem "trfTypeEqs: no where found after closed type family" loc:_ -> makeList "\n" (pure $ srcSpanStart loc) (mapM trfTypeEq (fromMaybe [] eqs)) trfTypeEq :: TransformName n r => Located (TyFamInstEqn n) -> Trf (Ann AST.UTypeEqn (Dom r) RangeStage) -trfTypeEq = trfLocNoSema $ \(TyFamEqn name pats rhs) +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] | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs) @@ -401,7 +410,7 @@ trfClassElemSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.UClassElement (Dom r) RangeStage) trfClassElemSig = trfLocNoSema $ \case TypeSig names typ -> AST.UClsSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) - <*> trfType (hswc_body $ hsib_body typ)) + <*> trfType (hsib_body $ hswc_body typ)) ClassOpSig True [name] typ -> AST.UClsDefSig <$> trfName name <*> trfType (hsib_body typ) ClassOpSig False names typ -> AST.UClsSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) <*> trfType (hsib_body typ)) @@ -414,16 +423,16 @@ trfTypeFam = trfLocNoSema trfTypeFam' trfTypeFam' :: TransformName n r => FamilyDecl n -> Trf (AST.UTypeFamily (Dom r) RangeStage) -trfTypeFam' (FamilyDecl DataFamily name tyVars kindSig _) +trfTypeFam' (FamilyDecl DataFamily name tyVars _ kindSig _) = AST.UDataFamily <$> (case unLoc kindSig of KindSig _ -> between AnnData AnnDcolon; _ -> id) (createDeclHead name tyVars) - <*> trfFamilyKind kindSig -trfTypeFam' (FamilyDecl OpenTypeFamily name tyVars kindSig injectivity) + <*> trfFamilyKind kindSig +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" +trfTypeFam' (FamilyDecl (ClosedTypeFamily {}) _ _ _ _ _) = convertionProblem "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) +trfTypeFamDef = trfLocNoSema $ \(TyFamEqn con pats _ rhs) -> AST.UClsTypeDef <$> between AnnType AnnEqual (createDeclHead con pats) <*> trfType rhs trfInstBody :: TransformName n r => LHsBinds n -> [LSig n] -> [LTyFamInstDecl n] -> [LDataFamInstDecl n] -> Trf (AnnMaybeG AST.UInstBody (Dom r) RangeStage) @@ -445,7 +454,7 @@ trfClassInstSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage) trfClassInstSig = trfLocNoSema $ \case TypeSig names typ -> AST.UInstBodyTypeSig <$> (annContNoSema $ AST.UTypeSignature <$> makeNonemptyList ", " (mapM trfName names) - <*> trfType (hswc_body $ hsib_body typ)) + <*> trfType (hsib_body $ hswc_body typ)) ClassOpSig _ names typ -> AST.UInstBodyTypeSig <$> (annContNoSema $ AST.UTypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) <*> trfType (hsib_body typ)) SpecInstSig _ typ -> AST.USpecializeInstance <$> trfType (hsib_body typ) @@ -458,7 +467,7 @@ trfInstDataFam :: TransformName n r => Located (DataFamInstDecl n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage) trfInstDataFam = trfLocNoSema $ \case - (DataFamInstDecl tc (hsib_body -> pats) (HsDataDefn dn ctx _ ks cons derivs) _) + (DataFamInstDecl tc (hsib_body -> pats) _ (HsDataDefn dn ctx _ ks cons derivs) _) | all ((\case ConDeclH98{} -> True; _ -> False) . unLoc) cons -> AST.UInstBodyDataDecl <$> trfDataKeyword dn @@ -467,7 +476,7 @@ <*> trfCtx atTheStart ctx <*> transformNameAndPats tc pats) <*> trfAnnList "" trfConDecl' cons - <*> trfMaybe " deriving " "" trfDerivings derivs + <*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs)) | otherwise -> AST.UInstBodyGadtDataDecl <$> trfDataKeyword dn @@ -477,8 +486,8 @@ <*> transformNameAndPats tc pats) <*> trfKindSig ks <*> trfAnnList "" trfGADTConDecl' cons - <*> trfMaybe " deriving " "" trfDerivings derivs - where transformNameAndPats tc pats + <*> makeIndentedList atTheEnd (mapM trfDerivings (unLoc derivs)) + where transformNameAndPats tc pats -- TODO: this is simpler with lexical fixity | all (\p -> srcSpanEnd (getLoc tc) < srcSpanStart (getLoc p)) pats -- prefix instance head application = foldl (\r t -> annLocNoSema (combineSrcSpans (getLoc t) . getRange <$> r) (AST.UInstanceHeadApp <$> r <*> (trfType t))) @@ -499,16 +508,16 @@ rewrites = case lhs of RecordPatSyn flds -> map (\r -> (unLoc (recordPatSynPatVar r), unLoc (recordPatSynSelectorId r))) flds _ -> [] changedRhs = biplateRef .- (\n -> case lookup n rewrites of Just x -> x; Nothing -> n) $ def - in AST.UPatternSynonym <$> trfPatSynLhs id lhs + in AST.UPatternSynonym <$> trfPatSynLhs id lhs sep <*> annLocNoSema rhsLoc (trfPatSynRhs dir changedRhs) - where trfPatSynLhs :: Located n -> HsPatSynDetails (Located n) -> Trf (Ann AST.UPatSynLhs (Dom r) RangeStage) - trfPatSynLhs id (PrefixPatSyn args) + where trfPatSynLhs :: Located n -> HsPatSynDetails (Located n) -> AnnKeywordId -> Trf (Ann AST.UPatSynLhs (Dom r) RangeStage) + trfPatSynLhs id (PrefixPatSyn args) _ = annLocNoSema (pure $ foldLocs (getLoc id : map getLoc args)) $ AST.UNormalPatSyn <$> define (trfName id) <*> trfAnnList " " trfName' args - trfPatSynLhs op (InfixPatSyn lhs rhs) + trfPatSynLhs op (InfixPatSyn lhs rhs) _ = annLocNoSema (pure $ getLoc lhs `combineSrcSpans` getLoc rhs) $ AST.UInfixPatSyn <$> define (trfName lhs) <*> trfOperator op <*> trfName rhs - trfPatSynLhs id (RecordPatSyn flds) - = annLocNoSema (mkSrcSpan (srcSpanStart (getLoc id)) <$> before AnnEqual) + trfPatSynLhs id (RecordPatSyn flds) kw + = annLocNoSema (mkSrcSpan (srcSpanStart (getLoc id)) <$> before kw) $ AST.URecordPatSyn <$> define (trfName id) <*> trfAnnList ", " trfName' (map recordPatSynSelectorId flds) trfPatSynRhs :: HsPatSynDir n -> Located (Pat n) -> Trf (AST.UPatSynRhs (Dom r) RangeStage) @@ -523,7 +532,7 @@ trfFamilyKind (unLoc -> fr) = case fr of NoSig -> nothing "" " " atTheEnd KindSig k -> trfKindSig (Just k) - TyVarSig _ -> error "trfFamilyKind: TyVarSig not supported" + TyVarSig _ -> convertionProblem "trfFamilyKind: TyVarSig not supported" 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 @@ -536,7 +545,7 @@ _ -> annLocNoSema (pure $ getLoc n) (AST.UTyVarDecl <$> trfName n <*> nothing "" "" (pure $ srcSpanEnd (getLoc n))) trfAnnotationSubject :: TransformName n r => SourceText -> AnnProvenance n -> SrcLoc -> Trf (Ann AST.UAnnotationSubject (Dom r) RangeStage) -trfAnnotationSubject stxt subject payloadEnd +trfAnnotationSubject (fromSrcText -> stxt) subject payloadEnd = do payloadStart <- advanceStr stxt <$> atTheStart case subject of ValueAnnProvenance name@(L l _) -> annLocNoSema (pure l) (AST.UNameAnnotation <$> trfName name) TypeAnnProvenance name@(L l _) -> annLocNoSema (pure $ mkSrcSpan payloadStart (srcSpanEnd l)) @@ -555,7 +564,7 @@ trfCallConv' CApiConv = pure AST.UCApi trfCallConv' StdCallConv = pure AST.UStdCall trfCallConv' JavaScriptCallConv = pure AST.UJavaScript -trfCallConv' PrimCallConv = error "trfCallConv: PrimCallConv not supported" +trfCallConv' PrimCallConv = convertionProblem "trfCallConv: PrimCallConv not supported" trfSafety :: SrcSpan -> Located Safety -> Trf (AnnMaybeG AST.USafety (Dom r) RangeStage) trfSafety ccLoc lsaf@(L l _) | isGoodSrcSpan l @@ -577,7 +586,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" + Nothing -> convertionProblem "trfRole: no role" trfRewriteRule :: TransformName n r => Located (RuleDecl n) -> Trf (Ann AST.URule (Dom r) RangeStage) trfRewriteRule = trfLocNoSema $ \(HsRule (L nameLoc (_, ruleName)) act bndrs left _ right _) -> @@ -589,13 +598,15 @@ trfRuleBndr :: TransformName n r => Located (RuleBndr n) -> Trf (Ann AST.URuleVar (Dom r) RangeStage) trfRuleBndr = trfLocNoSema $ \case (RuleBndr n) -> AST.URuleVar <$> trfName n - (RuleBndrSig n k) -> AST.USigRuleVar <$> trfName n <*> trfType (hswc_body $ hsib_body k) + (RuleBndrSig n k) -> AST.USigRuleVar <$> trfName n <*> trfType (hsib_body $ hswc_body k) trfMinimalFormula :: TransformName n r => Located (BooleanFormula (Located n)) -> Trf (Ann AST.UMinimalFormula (Dom r) RangeStage) -trfMinimalFormula = trfLocNoSema trfMinimalFormula' +trfMinimalFormula = trfLocCorrect (pure mkNoSemanticInfo) + (\sp -> if isGoodSrcSpan sp then pure sp else srcLocSpan <$> before AnnClose) trfMinimalFormula' trfMinimalFormula' :: TransformName n r => BooleanFormula (Located n) -> Trf (AST.UMinimalFormula (Dom r) RangeStage) trfMinimalFormula' (Var name) = AST.UMinimalName <$> trfName name -trfMinimalFormula' (And formulas) = AST.UMinimalAnd <$> trfAnnList " & " trfMinimalFormula' formulas +trfMinimalFormula' (And formulas) -- empty Minimal pragma is mapped to an empty list + = AST.UMinimalAnd <$> makeListBefore " " " , " atTheEnd (mapM (trfLocNoSema trfMinimalFormula') formulas) trfMinimalFormula' (Or formulas) = AST.UMinimalOr <$> trfAnnList " | " trfMinimalFormula' formulas trfMinimalFormula' (Parens formula) = AST.UMinimalParen <$> trfMinimalFormula formula
Language/Haskell/Tools/BackendGHC/Exprs.hs view
@@ -1,9 +1,4 @@-{-# LANGUAGE LambdaCase - , ViewPatterns - , ScopedTypeVariables - , TypeApplications - , AllowAmbiguousTypes - #-} +{-# LANGUAGE AllowAmbiguousTypes, LambdaCase, ScopedTypeVariables, TypeApplications, ViewPatterns #-} -- | Functions that convert the expression-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Exprs where @@ -42,7 +37,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" + _ -> convProblem "trfExpr: case without 'of' '{' or '}' token" annLoc createScopeInfo (pure actualSpan) (trfExpr' cs) trfExpr e | RealSrcSpan loce <- getLoc e = do exprSpls <- asks exprSplices @@ -71,7 +66,7 @@ trfExpr' (HsLit val) = AST.ULit <$> annContNoSema (trfLiteral' val) trfExpr' (HsLam (unLoc . mg_alts -> [unLoc -> Match _ pats _ (GRHSs [unLoc -> GRHS [] expr] (unLoc -> EmptyLocalBinds))])) = AST.ULambda <$> (makeNonemptyList " " $ mapM trfPattern pats) <*> addToScope pats (trfExpr expr) -trfExpr' (HsLamCase _ (unLoc . mg_alts -> matches)) = AST.ULamCase <$> trfAnnList " " trfAlt' matches +trfExpr' (HsLamCase (unLoc . mg_alts -> matches)) = AST.ULamCase <$> addToScope matches (trfAnnList " " trfAlt' matches) trfExpr' (HsApp e1 e2) = AST.UApp <$> trfExpr e1 <*> trfExpr e2 trfExpr' (OpApp e1 (unLoc -> HsVar op) _ e2) = AST.UInfixApp <$> trfExpr e1 <*> trfOperator op <*> trfExpr e2 @@ -81,7 +76,7 @@ trfExpr' (NegApp e _) = AST.UPrefixApp <$> annLocNoSema loc (AST.UNormalOp <$> annLoc info loc (AST.nameFromList <$> trfOperatorStr False "-")) <*> trfExpr e where loc = mkSrcSpan <$> atTheStart <*> (pure $ srcSpanStart (getLoc e)) - info = createNameInfo =<< (fromMaybe (error "minus operation is not found") <$> liftGhc negateOpName) + info = createNameInfo =<< (fromMaybe (convProblem "minus operation is not found") <$> liftGhc negateOpName) negateOpName = getFromNameUsing (\n -> (\case Just (AnId id) -> Just id; _ -> Nothing) <$> lookupName n) negateName trfExpr' (HsPar (unLoc -> SectionL expr (unLoc -> HsVar op))) = AST.ULeftSection <$> trfExpr expr <*> trfOperator op trfExpr' (HsPar (unLoc -> SectionL expr (L nameLoc (HsRecFld op)))) @@ -122,7 +117,7 @@ | realSp `containsSpan` realSep = [mkSrcSpan (srcSpanStart sp) (srcSpanStart sep), mkSrcSpan (srcSpanEnd sep) (srcSpanEnd sp)] breakUpOne _ sp = [sp] -trfExpr' (HsCase expr (unLoc . mg_alts -> cases)) = AST.UCase <$> trfExpr expr <*> (makeIndentedList (focusBeforeIfPresent AnnCloseC atTheEnd) (mapM trfAlt cases)) +trfExpr' (HsCase expr (unLoc . mg_alts -> cases)) = AST.UCase <$> trfExpr expr <*> (addToScope cases $ makeIndentedList (focusBeforeIfPresent AnnCloseC atTheEnd) (mapM trfAlt cases)) trfExpr' (HsIf _ expr thenE elseE) = AST.UIf <$> trfExpr expr <*> trfExpr thenE <*> trfExpr elseE trfExpr' (HsMultiIf _ parts) = AST.UMultiIf <$> trfAnnList "" trfGuardedCaseRhs' parts trfExpr' (HsLet (unLoc -> binds) expr) = addToScope binds (AST.ULet <$> trfLocalBinds AnnLet binds <*> trfExpr expr) @@ -143,7 +138,7 @@ trfExpr' (ExplicitPArr _ exprs) = AST.UParArray <$> trfAnnList' ", " trfExpr exprs trfExpr' (RecordCon name _ _ fields) = AST.URecCon <$> trfName name <*> trfFieldInits fields trfExpr' (RecordUpd expr fields _ _ _ _) = AST.URecUpdate <$> trfExpr expr <*> trfAnnList ", " trfFieldUpdate fields -trfExpr' (ExprWithTySig expr typ) = AST.UTypeSig <$> trfExpr expr <*> trfType (hswc_body $ hsib_body typ) +trfExpr' (ExprWithTySig expr typ) = AST.UTypeSig <$> trfExpr expr <*> trfType (hsib_body $ hswc_body typ) trfExpr' (ArithSeq _ _ (From from)) = AST.UEnum <$> trfExpr from <*> nothing "," "" (before AnnDotdot) <*> nothing "" "" (before AnnCloseS) trfExpr' (ArithSeq _ _ (FromThen from step)) @@ -162,7 +157,7 @@ trfExpr' (HsSpliceE splice) = AST.USplice <$> trfSplice splice trfExpr' (HsRnBracketOut br _) = AST.UBracketExpr <$> annContNoSema (trfBracket' br) trfExpr' (HsProc pat cmdTop) = AST.UProc <$> trfPattern pat <*> trfCmdTop cmdTop -trfExpr' (HsStatic expr) = AST.UStaticPtr <$> trfExpr expr +trfExpr' (HsStatic _ expr) = AST.UStaticPtr <$> trfExpr expr trfExpr' (HsAppType expr typ) = AST.UExplTypeApp <$> trfExpr expr <*> trfType (hswc_body typ) trfExpr' (HsSCC _ lit expr) = AST.UExprPragma <$> pragma <*> trfExpr expr where pragma = do pragLoc <- tokensLoc [AnnOpen, AnnClose] @@ -173,6 +168,15 @@ trfExpr' (HsTickPragma _ source _ expr) = AST.UExprPragma <$> pragma <*> trfExpr expr where pragma = do pragLoc <- tokensLoc [AnnOpen, AnnClose] focusOn pragLoc $ annContNoSema (AST.UGeneratedPragma <$> (trfSourceRange source)) +trfExpr' (ExplicitSum tag arity expr _) + = do sepsBefore <- focusBeforeLoc (srcSpanStart (getLoc expr)) (eachTokenLoc (AnnOpen : replicate (tag - 1) AnnVbar)) + sepsAfter <- focusAfterLoc (srcSpanEnd (getLoc expr)) (eachTokenLoc (replicate (arity - tag) AnnVbar)) + let locsBefore = map srcSpanEnd $ init sepsBefore + locsAfter = map srcSpanEnd sepsAfter + AST.UUnboxedSum <$> makeList " | " (after AnnOpen) (mapM makePlaceholder locsBefore) + <*> trfExpr expr + <*> makeList " | " (before AnnClose) (mapM makePlaceholder locsAfter) + where makePlaceholder l = annLocNoSema (pure (srcLocSpan l)) (pure AST.UUnboxedSumPlaceHolder) trfExpr' t = unhandledElement "expression" t trfFieldInits :: TransformName n r => HsRecFields n (LHsExpr n) -> Trf (AnnListG AST.UFieldUpdate (Dom r) RangeStage) @@ -203,7 +207,7 @@ 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] _ (GRHSs rhss (unLoc -> locBinds))) = AST.UAlt <$> trfPattern pat <*> gTrfCaseRhss te rhss <*> trfWhereLocalBinds (collectLocs rhss) locBinds -gTrfAlt' _ _ = error "gTrfAlt': not exactly one alternative when transforming a case alternative" +gTrfAlt' _ _ = convertionProblem "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 @@ -237,7 +241,7 @@ (HsHigherOrderApp, False) -> annLocNoSema (tokenLoc AnnRarrowtail) (pure AST.URightHighApp) (HsHigherOrderApp, True) -> annLocNoSema (tokenLoc AnnLarrowtail) (pure AST.ULeftHighApp) -- FIXME: needs a before -trfCmd' (HsCmdArrForm expr _ cmds) = AST.UArrowFormCmd <$> trfExpr expr <*> makeList " " (before AnnClose) (mapM trfCmdTop cmds) +trfCmd' (HsCmdArrForm expr _ _ cmds) = AST.UArrowFormCmd <$> trfExpr expr <*> makeList " " (before AnnClose) (mapM trfCmdTop cmds) trfCmd' (HsCmdApp cmd expr) = AST.UAppCmd <$> trfCmd cmd <*> trfExpr expr trfCmd' (HsCmdLam (MG (unLoc -> [unLoc -> Match _ pats _ (GRHSs [unLoc -> GRHS [] body] _)]) _ _ _)) = AST.ULambdaCmd <$> (makeNonemptyList " " $ mapM trfPattern pats) <*> trfCmd body @@ -248,8 +252,8 @@ trfCmd' (HsCmdLet (unLoc -> binds) cmd) = addToScope binds (AST.ULetCmd <$> trfLocalBinds AnnLet binds <*> trfCmd cmd) 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" +trfCmd' (HsCmdLam {}) = convertionProblem "trfCmd': cmd lambda not supported yet" +trfCmd' (HsCmdWrap {}) = convertionProblem "trfCmd': cmd wrap not supported yet" trfText' :: StringLiteral -> Trf (AST.UStringNode (Dom r) RangeStage) trfText' = pure . AST.UStringNode . unpackFS . sl_fs
Language/Haskell/Tools/BackendGHC/GHCUtils.hs view
@@ -1,11 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses - , TypeSynonymInstances - , FlexibleInstances - , ScopedTypeVariables - , ViewPatterns - , LambdaCase - , RecordWildCards - #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables #-} -- | Utility functions defined on the GHC AST representation. module Language.Haskell.Tools.BackendGHC.GHCUtils where @@ -13,18 +6,19 @@ import Data.List import Bag (Bag, bagToList, unionManyBags) +import BasicTypes (SourceText(..)) import ConLike (ConLike(..)) +import Data.Maybe (Maybe(..), listToMaybe) import GHC import Id (Id, mkVanillaGlobal) import OccName (OccName) -import Outputable (Outputable(..), OutputableBndr(..), showSDocUnsafe) +import Outputable (Outputable(..), showSDocUnsafe) import PatSyn (patSynSig) import RdrName (RdrName, rdrNameOcc, nameRdrName) import SrcLoc import Type (TyThing(..), mkFunTys) -import Data.Maybe -class OutputableBndr name => GHCName name where +class OutputableBndrId name => GHCName name where rdrName :: name -> RdrName getFromNameUsing :: Applicative f => (Name -> Ghc (f Id)) -> Name -> Ghc (f name) getBindsAndSigs :: HsValBinds name -> ([LSig name], LHsBinds name) @@ -117,7 +111,7 @@ hsGetNames p dfid = hsGetNames p (dfid_defn dfid) instance (GHCName n, HsHasName n) => HsHasName (TyClGroup n) where - hsGetNames p (TyClGroup tycls _) = hsGetNames p tycls + hsGetNames p (TyClGroup tycls _ _) = hsGetNames p tycls instance (GHCName n, HsHasName n) => HsHasName (TyClDecl n) where hsGetNames p (FamDecl fd) = hsGetNames p fd @@ -135,9 +129,9 @@ hsGetNames p (HsDataDefn {dd_cons = ctors}) = hsGetNames p ctors instance (GHCName n, HsHasName n) => HsHasName (ConDecl n) where - hsGetNames p (ConDeclGADT {con_names = names, con_type = (HsIB _ (L _ (HsFunTy (L _ (HsRecTy flds)) _)))}) + hsGetNames p (ConDeclGADT {con_names = names, con_type = (HsIB _ (L _ (HsFunTy (L _ (HsRecTy flds)) _)) _)}) = hsGetNames p names ++ hsGetNames p flds - hsGetNames p (ConDeclGADT {con_names = names, con_type = (HsIB _ (L _ (HsRecTy flds)))}) + hsGetNames p (ConDeclGADT {con_names = names, con_type = (HsIB _ (L _ (HsRecTy flds)) _)}) = hsGetNames p names ++ hsGetNames p flds hsGetNames p (ConDeclGADT {con_names = names}) = hsGetNames p names hsGetNames p (ConDeclH98 {con_name = name, con_details = details}) @@ -187,6 +181,9 @@ hsGetNames p (UserTyVar n) = hsGetNames p n hsGetNames p (KindedTyVar n _) = hsGetNames p n +instance HsHasName n => HsHasName (Match n b) where + hsGetNames p (Match _ pats _ _) = concatMap (hsGetNames p) pats + instance HsHasName n => HsHasName (Stmt n b) where hsGetNames p (LetStmt binds) = hsGetNames p binds hsGetNames p (BindStmt pat _ _ _ _) = hsGetNames p pat @@ -211,8 +208,8 @@ hsGetNames _ _ = [] instance (GHCName n, HsHasName n) => HsHasName (HsGroup n) where - hsGetNames p (HsGroup vals _ clds insts _ _ _ foreigns _ _ _ _ _) - = hsGetNames p vals ++ hsGetNames p clds ++ hsGetNames p insts ++ hsGetNames p foreigns + hsGetNames p g@(HsGroup vals _ clds _ _ _ foreigns _ _ _ _ _) + = hsGetNames p vals ++ hsGetNames p clds ++ hsGetNames p (hsGroupInstDecls g) ++ hsGetNames p foreigns -- | Get the original form of a name rdrNameStr :: RdrName -> String @@ -230,12 +227,12 @@ -- | Tries to simplify the type that has HsAppsTy before renaming. Does not always provide the correct form. -- Treats each operator as if they are of equivalent precedence and always left-associative. -cleanHsType :: forall n . (OutputableBndr n) => HsType n -> HsType n +cleanHsType :: forall n . (OutputableBndrId n) => HsType n -> HsType n -- for some reason * is considered infix cleanHsType (HsAppsTy apps) = unLoc $ guessType apps - where guessType :: OutputableBndr n => [LHsAppType n] -> LHsType n + where guessType :: OutputableBndrId n => [LHsAppType n] -> LHsType n guessType (L l (HsAppInfix n) : rest) -- must be a prefix actually - = guessType' (L l (HsTyVar n)) rest + = guessType' (L l (HsTyVar NotPromoted n)) rest guessType (L _ (HsAppPrefix t) : rest) = guessType' t rest guessType [] = error $ "guessType: empty: " ++ showSDocUnsafe (ppr apps) @@ -243,7 +240,7 @@ guessType' fun (L _ (HsAppPrefix t) : rest) = guessType' (hsAppTy fun t) rest guessType' fun (L l (HsAppInfix n) : rest) -- TODO: find a better check - | showSDocUnsafe (ppr n) == "*" = guessType' (hsAppTy fun (L l (HsTyVar n))) rest + | showSDocUnsafe (ppr n) == "*" = guessType' (hsAppTy fun (L l (HsTyVar NotPromoted n))) rest guessType' left (L _ (HsAppInfix n) : right) = hsOpTy left n (guessType right) guessType' t [] = t @@ -265,10 +262,14 @@ getGroupRange (HsGroup {..}) = foldr combineSrcSpans noSrcSpan locs where locs = [getHsValRange hs_valds] ++ map getLoc hs_splcds ++ map getLoc (concatMap group_tyclds hs_tyclds) ++ map getLoc (concatMap group_roles hs_tyclds) - ++ map getLoc hs_instds ++ map getLoc hs_derivds ++ map getLoc hs_fixds ++ map getLoc hs_defds + ++ map getLoc hs_derivds ++ map getLoc hs_fixds ++ map getLoc hs_defds ++ map getLoc hs_fords ++ map getLoc hs_warnds ++ map getLoc hs_annds ++ map getLoc hs_ruleds ++ map getLoc hs_vects ++ map getLoc hs_docs getHsValRange :: HsValBinds n -> SrcSpan getHsValRange (ValBindsIn vals sig) = foldr combineSrcSpans noSrcSpan $ map getLoc (bagToList vals) ++ map getLoc sig getHsValRange (ValBindsOut vals sig) = foldr combineSrcSpans noSrcSpan $ concatMap (map getLoc . bagToList . snd) vals ++ map getLoc sig + +fromSrcText :: SourceText -> String +fromSrcText (SourceText s) = s +fromSrcText NoSourceText = ""
Language/Haskell/Tools/BackendGHC/Kinds.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE ViewPatterns - , TypeFamilies - #-} +{-# LANGUAGE TypeFamilies, ViewPatterns #-} -- | Functions that convert the kind-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Kinds where @@ -32,7 +30,7 @@ trfKind' ::TransformName n r => HsKind n -> Trf (AST.UKind (Dom r) RangeStage) trfKind' = trfKind'' . cleanHsType where - trfKind'' (HsTyVar (rdrName . unLoc -> Exact n)) + trfKind'' (HsTyVar _ (rdrName . unLoc -> Exact n)) | isWiredInName n && occNameString (nameOccName n) == "*" = pure AST.UStarKind | isWiredInName n && occNameString (nameOccName n) == "#" @@ -41,7 +39,7 @@ trfKind'' (HsFunTy k1 k2) = AST.UFunKind <$> trfKind k1 <*> trfKind k2 trfKind'' (HsAppTy k1 k2) = AST.UAppKind <$> trfKind k1 <*> trfKind k2 trfKind'' (HsOpTy k1 op k2) = AST.UInfixAppKind <$> trfKind k1 <*> trfOperator op <*> trfKind k2 - trfKind'' (HsTyVar kv) = transformingPossibleVar kv (AST.UVarKind <$> trfName kv) + trfKind'' (HsTyVar _ kv) = transformingPossibleVar kv (AST.UVarKind <$> trfName kv) trfKind'' (HsListTy kind) = AST.UListKind <$> trfKind kind trfKind'' (HsTupleTy _ kinds) = AST.UTupleKind <$> makeList ", " atTheStart (mapM trfKind kinds) trfKind'' (HsAppsTy [unLoc -> HsAppPrefix t]) = trfKind' (unLoc t) @@ -55,7 +53,7 @@ => (HsType n -> Trf (a (Dom r) RangeStage)) -> HsType n -> Trf (AST.UPromoted a (Dom r) RangeStage) 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' _ (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 = unhandledElement "promoted type/kind" t
Language/Haskell/Tools/BackendGHC/Literals.hs view
@@ -8,7 +8,7 @@ import HsLit as GHC (OverLitVal(..), HsLit(..)) import Language.Haskell.Tools.AST (Dom, RangeStage) -import qualified Language.Haskell.Tools.AST as AST (ULiteral(..), Dom, RangeStage) +import qualified Language.Haskell.Tools.AST as AST (ULiteral(..)) import Language.Haskell.Tools.BackendGHC.Monad (Trf) trfLiteral' :: HsLit -> Trf (AST.ULiteral (Dom r) RangeStage)
Language/Haskell/Tools/BackendGHC/Modules.hs view
@@ -1,24 +1,17 @@-{-# LANGUAGE LambdaCase - , ViewPatterns - , FlexibleContexts - , ScopedTypeVariables - , TypeApplications - , TupleSections - , TypeFamilies - #-} +{-# LANGUAGE BangPatterns, FlexibleContexts, LambdaCase, ScopedTypeVariables, TypeApplications, TypeFamilies, ViewPatterns #-} -- | Functions that convert the module-related elements (modules, imports, exports) of the GHC AST to corresponding elements in the Haskell-tools AST representation -- Also contains the entry point of the transformation that collects the information from different GHC AST representations. module Language.Haskell.Tools.BackendGHC.Modules where import Control.Monad.Reader import Control.Reference hiding (element) +import Data.Char (isSpace) import Data.Generics.Uniplate.Data () import Data.List as List import Data.Map as Map (fromList, lookup) import Data.Maybe import BasicTypes as GHC (WarningTxt(..), StringLiteral(..)) -import DynFlags as GHC () import FastString as GHC (unpackFS) import FieldLabel as GHC (FieldLbl(..)) import GHC @@ -35,27 +28,46 @@ import Language.Haskell.Tools.BackendGHC.Names (TransformName, trfName) import Language.Haskell.Tools.BackendGHC.Utils +-- Transformes a module in its renamed state. This will be performed to help the transformation of the actual typed module representation. trfModule :: ModSummary -> Located (HsModule RdrName) -> Trf (Ann AST.UModule (Dom RdrName) RangeStage) -trfModule mod hsMod = trfLocCorrect (createModuleInfo mod (maybe noSrcSpan getLoc $ hsmodName $ unLoc hsMod) (hsmodImports $ unLoc hsMod)) - (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) - (\(HsModule name exports imports decls deprec _) -> - AST.UModule <$> trfFilePragmas - <*> trfModuleHead name (srcSpanStart (foldLocs (map getLoc imports ++ map getLoc decls))) exports deprec - <*> trfImports imports - <*> trfDecls decls) $ hsMod +trfModule mod hsMod = do -- createModuleInfo involves reading the ghc compiler state, so it must be evaluated + -- or large parts of the representation will be kept + !modInfo <- createModuleInfo mod (maybe noSrcSpan getLoc $ hsmodName $ unLoc hsMod) (hsmodImports $ unLoc hsMod) + trfLocCorrect (pure modInfo) + (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) + (\(HsModule name exports imports decls deprec _) -> + AST.UModule <$> trfFilePragmas + <*> trfModuleHead name (srcSpanStart (foldLocs (map getLoc imports ++ map getLoc decls))) exports deprec + <*> trfImports imports + <*> trfDecls decls) $ hsMod +-- | Transformes the module in its typed state. Uses the results of 'trfModule' to extract program +-- elements (splices for example) that are not kept in the typed representation. trfModuleRename :: ModSummary -> Ann AST.UModule (Dom RdrName) RangeStage -> (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString) -> Located (HsModule RdrName) -> Trf (Ann AST.UModule (Dom GHC.Name) RangeStage) trfModuleRename mod rangeMod (gr,imports,exps,_) hsMod - = do info <- createModuleInfo mod (maybe noSrcSpan getLoc $ hsmodName $ unLoc hsMod) imports + = do -- createModuleInfo involves reading the ghc compiler state, so it must be evaluated + -- or large parts of the representation will be kept + !info <- createModuleInfo mod (maybe noSrcSpan getLoc $ hsmodName $ unLoc hsMod) imports trfLocCorrect (pure info) (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) (trfModuleRename' (info ^. implicitNames)) hsMod where roleAnnots = rangeMod ^? AST.modDecl&AST.annList&filtered ((\case Ann _ (AST.URoleDecl {}) -> True; _ -> False)) originalNames = Map.fromList $ catMaybes $ map getSourceAndInfo (rangeMod ^? biplateRef) getSourceAndInfo :: Ann AST.UQualifiedName (Dom RdrName) RangeStage -> Maybe (SrcSpan, RdrName) getSourceAndInfo n = (,) <$> (n ^? annotation&sourceInfo&nodeSpan) <*> (n ^? semantics&nameInfo) + exportDecls = rangeMod ^? AST.modHead & AST.annJust & AST.mhExports & AST.annJust & AST.espExports & AST.annList + exportSubspecs = map (\e -> e ^? AST.exportDecl & AST.ieSubspec & AST.annJust & AST.essList & AST.annList) exportDecls + exportSubspecsRngs = map (map AST.getRange) exportSubspecs + + replaceSubspecLocs :: [LIE Name] -> [LIE Name] + replaceSubspecLocs exps = zipWith (\ss ie -> case ie of (L l (IEThingWith n wc ls flds)) -> L l (IEThingWith n wc (replaceNames ss ls) (replaceFieldNames (drop (length ls) ss) flds)) + _ -> ie) exportSubspecsRngs exps + where replaceNames ss ls = zipWith (\(L _ iew) l -> case iew of IEName (L _ n) -> L l (IEName (L l n)) + _ -> L l iew) ls ss + replaceFieldNames ss ls = zipWith (\(L _ iew) l -> L l iew) ls ss + trfModuleRename' preludeImports hsMod@(HsModule name exports _ _ deprec _) = do transformedImports <- orderAnnList <$> (trfImports imports) @@ -73,12 +85,13 @@ AST.UModule filePrags <$> trfModuleHead name (srcSpanEnd (AST.getRange filePrags)) - (case (exports, exps) of (Just (L l _), Just ie) -> Just (L l ie) + (case (exports, exps) of (Just (L l _), Just ie) -> Just (L l (replaceSubspecLocs (orderLocated ie))) _ -> Nothing) deprec <*> return transformedImports <*> trfDeclsGroup gr +-- | Extract the template haskell splices from the representation and adds them to the transformation state. loadSplices :: HsModule RdrName -> Trf a -> Trf a loadSplices hsMod trf = do let declSpls = map (\(SpliceDecl sp _) -> sp) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)] @@ -93,7 +106,7 @@ <*> trfModulePragma (srcSpanEnd $ getLoc mn) modPrag <*> trfExportList (before AnnWhere) exports)) trfModuleHead _ rng Nothing _ = nothing "" "" (pure rng) -trfModuleHead Nothing _ (Just _) _ = error "trfModuleHead: no head but has exports" +trfModuleHead Nothing _ (Just _) _ = convertionProblem "trfModuleHead: no head but has exports" trfFilePragmas :: Trf (AnnListG AST.UFilePragma (Dom r) RangeStage) trfFilePragmas = do pragmas <- asks pragmaComms @@ -104,12 +117,12 @@ trfLanguagePragma :: Located String -> Trf (Ann AST.UFilePragma (Dom r) RangeStage) 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 + where pragmaElems = splitLocatedOn (\c -> isSpace c || c == ',') lstr extensions = filter ((\sp -> srcSpanStart sp /= srcSpanEnd sp) . getLoc) $ map (removeEnd . removeLang . removeStart) pragmaElems - removeStart pr@(L l txt) = if "{-#" `isPrefixOf` txt then L (updateStart (updateCol (+3)) l) (drop 3 txt) else pr - removeLang pr@(L l txt) = if "LANGUAGE" `isPrefixOf` txt then L (updateStart (updateCol (+8)) l) (drop 8 txt) else pr - removeEnd pr@(L l txt) = if "#-}" `isSuffixOf` txt then L (updateEnd (updateCol (subtract 3)) l) (reverse $ drop 3 $ reverse $ txt) else pr + removeStart pr@(L l txt) = if "{-#" `isPrefixOf` txt then L (updateStart (updateCol (+3)) l) (drop 3 txt) else pr + removeLang pr@(L l txt) = if "LANGUAGE" `isPrefixOf` txt then L (updateStart (updateCol (+8)) l) (drop 8 txt) else pr + removeEnd pr@(L l txt) = if "#-}" `isSuffixOf` txt then L (updateEnd (updateCol (subtract 3)) l) (reverse $ drop 3 $ reverse $ txt) else pr trfOptionsPragma :: Located String -> Trf (Ann AST.UFilePragma (Dom r) RangeStage) trfOptionsPragma (L l str) = annLocNoSema (pure l) (AST.UOptionsPragma <$> annContNoSema (pure $ AST.UStringNode str)) @@ -145,7 +158,8 @@ annBeforeSafe = if isQual then AnnQualified else annBeforeQual annBeforePkg = if isGoodSrcSpan safeTok then AnnSafe else annBeforeSafe - annLoc (createImportData impDecl) (pure l) $ AST.UImportDecl + !importData <- createImportData impDecl + annLoc (pure importData) (pure l) $ AST.UImportDecl <$> (if isSrc then makeJust <$> annLocNoSema (tokensLoc [AnnOpen, AnnClose]) (pure AST.UImportSource) else nothing " " "" (after AnnImport)) <*> (if isQual then makeJust <$> (annLocNoSema (tokenLoc AnnQualified) (pure AST.UImportQualified)) @@ -157,10 +171,8 @@ <*> trfModuleName name <*> maybe (nothing " " "" (pure $ srcSpanEnd (getLoc name))) (\mn -> makeJust <$> (trfRenaming mn)) declAs <*> trfImportSpecs declHiding - where trfRenaming mn - = annLocNoSema (tokensLoc [AnnAs,AnnVal]) - (AST.UImportRenaming <$> (annLocNoSema (tokenLoc AnnVal) - (trfModuleName' mn))) + where trfRenaming mn = annLocNoSema (combineSrcSpans (getLoc mn) <$> tokenLoc AnnAs) + (AST.UImportRenaming <$> (trfModuleName mn)) trfImportSpecs :: TransformName n r => Maybe (Bool, Located [LIE n]) -> Trf (AnnMaybeG AST.UImportSpec (Dom r) RangeStage) trfImportSpecs (Just (True, l)) @@ -173,17 +185,23 @@ trfIESpec = trfMaybeLocNoSema trfIESpec' trfIESpec' :: TransformName n r => IE n -> Trf (Maybe (AST.UIESpec (Dom r) RangeStage)) -trfIESpec' (IEVar n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName n <*> (nothing "(" ")" atTheEnd)) -trfIESpec' (IEThingAbs n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName n <*> (nothing "(" ")" atTheEnd)) +trfIESpec' (IEVar n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName (getWrappedName n) <*> (nothing "(" ")" atTheEnd)) +trfIESpec' (IEThingAbs n) = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName (getWrappedName n) <*> (nothing "(" ")" atTheEnd)) trfIESpec' (IEThingAll n) - = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName n <*> (makeJust <$> subspec)) + = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName (getWrappedName n) <*> (makeJust <$> subspec)) where subspec = annLocNoSema (combineSrcSpans <$> tokenLocBack AnnOpenP <*> tokenLocBack AnnCloseP) (pure AST.USubSpecAll) trfIESpec' (IEThingWith n _ ls flds) - = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName n <*> (makeJust <$> subspec)) + = Just <$> (AST.UIESpec <$> trfImportModifier <*> trfName (getWrappedName n) <*> (makeJust <$> subspec)) where subspec = annLocNoSema (combineSrcSpans <$> tokenLocBack AnnOpenP <*> tokenLocBack AnnCloseP) - $ AST.USubSpecList <$> between AnnOpenP AnnCloseP (orderAnnList <$> makeList ", " atTheStart ((++) <$> mapM trfName ls <*> mapM trfName (map (fmap flSelector) flds))) + $ AST.USubSpecList <$> between AnnOpenP AnnCloseP (makeList ", " atTheStart ((++) <$> mapM (trfName . getWrappedName) ls <*> mapM trfName (map (fmap flSelector) flds))) trfIESpec' _ = pure Nothing +getWrappedName :: Located (IEWrappedName n) -> Located n +getWrappedName (L _ (IEName n)) = n +getWrappedName (L _ (IEPattern n)) = n +getWrappedName (L _ (IEType n)) = n + +-- TODO: easier with wrapped names trfImportModifier :: Trf (AnnMaybeG AST.UImportModifier (Dom r) RangeStage) trfImportModifier = do patLoc <- tokenLoc AnnPattern
Language/Haskell/Tools/BackendGHC/Monad.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE TupleSections #-} + -- | The transformation monad carries the necessary information that is passed top-down -- during the conversion from GHC AST to our representation. module Language.Haskell.Tools.BackendGHC.Monad where import Control.Applicative ((<|>)) +import Control.Exception (Exception, evaluate, throw) import Control.Monad.Reader import Control.Reference import Data.Function (on) @@ -136,6 +137,7 @@ rdrSplice :: HsSplice RdrName -> Trf (HsSplice GHC.Name) rdrSplice spl = do + rng <- asks contRange env <- liftGhc getSession locals <- unifyScopes [] <$> asks localsInScope let createLocalGRE (n,imp,p) = [GRE n (maybe NoParent ParentIs p) (isNothing imp) (maybe [] (map createGREImport) imp) ] @@ -150,14 +152,16 @@ $ tcHsSplice' spl let typecheckErrors = showSDocUnsafe (vcat (pprErrMsgBagWithLoc (fst (fst tcSpl))) <+> vcat (pprErrMsgBagWithLoc (snd (fst tcSpl)))) - when (not (null typecheckErrors)) $ liftIO $ putStrLn ("Typechecking of splice expressions: " ++ typecheckErrors) - return $ fromMaybe (error $ "Splice expression could not be typechecked.") + -- This function refers the ghc environment, we must evaluate the result or the reference + -- may be kept preventing garbage collection. + liftIO $ evaluate (snd tcSpl) + return $ fromMaybe (throw $ SpliceInsertionProblem rng typecheckErrors) (snd tcSpl) where - tcHsSplice' (HsTypedSplice id e) - = HsTypedSplice (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e) - tcHsSplice' (HsUntypedSplice id e) - = HsUntypedSplice (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e) + tcHsSplice' (HsTypedSplice dec id e) + = HsTypedSplice dec (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e) + tcHsSplice' (HsUntypedSplice dec id e) + = HsUntypedSplice dec (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e) tcHsSplice' (HsQuasiQuote id1 id2 sp fs) = pure $ HsQuasiQuote (mkUnboundNameRdr id1) (mkUnboundNameRdr id2) sp fs @@ -166,3 +170,8 @@ unifyScopes _ [] = [] unifyScopes ex (sc:scs) = filteredSc ++ unifyScopes (ex ++ map (^. _1) filteredSc) scs where filteredSc = filter ((\s -> isNothing $ find (\e -> occName e == occName s) ex) . (^. _1)) sc + +data SpliceInsertionProblem = SpliceInsertionProblem SrcSpan String + deriving Show + +instance Exception SpliceInsertionProblem
Language/Haskell/Tools/BackendGHC/Names.hs view
@@ -1,15 +1,4 @@-{-# LANGUAGE LambdaCase - , TupleSections - , TypeFamilies - , FlexibleInstances - , FlexibleContexts - , TypeSynonymInstances - , ScopedTypeVariables - , MultiParamTypeClasses - , UndecidableInstances - , AllowAmbiguousTypes - , TypeApplications - #-} +{-# LANGUAGE AllowAmbiguousTypes, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-} -- | Functions that convert the basic elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Names where @@ -21,6 +10,7 @@ import HsSyn as GHC import Name as GHC (isSymOcc, occNameString) import qualified Name as GHC (Name) +import OccName as GHC (HasOccName) import RdrName as GHC (RdrName) import SrcLoc as GHC @@ -69,7 +59,7 @@ <$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfOperatorStr (not $ isSymOcc (occName rdr)) (rdrNameStr rdr)) -class (DataId n, Eq n, GHCName n, FromGHCName n) => TransformableName n where +class (DataId n, Eq n, GHCName n, FromGHCName n, NameOrRdrName n ~ n, HasOccName n) => TransformableName n where correctNameString :: n -> Trf String transformSplice :: HsSplice RdrName -> Trf (HsSplice n)
Language/Haskell/Tools/BackendGHC/Patterns.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE LambdaCase - , ViewPatterns - , ScopedTypeVariables - , AllowAmbiguousTypes - #-} +{-# LANGUAGE AllowAmbiguousTypes, ScopedTypeVariables, ViewPatterns #-} -- | Functions that convert the pattern-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Patterns where @@ -61,10 +57,19 @@ trfPattern' (SplicePat qq@(HsQuasiQuote {})) = AST.UQuasiQuotePat <$> annContNoSema (trfQuasiQuotation' qq) trfPattern' (SplicePat splice) = AST.USplicePat <$> trfSplice splice trfPattern' (LitPat lit) = AST.ULitPat <$> annContNoSema (trfLiteral' lit) -trfPattern' (SigPatIn pat (hswc_body . hsib_body -> typ)) = AST.UTypeSigPat <$> trfPattern pat <*> trfType typ +trfPattern' (SigPatIn pat (hsib_body . hswc_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)) trfPattern' (CoPat _ pat _) = trfPattern' pat -- coercion pattern introduced by GHC +trfPattern' (SumPat pat tag arity _) + = do sepsBefore <- focusBeforeLoc (srcSpanStart (getLoc pat)) (eachTokenLoc (AnnOpen : replicate (tag - 1) AnnVbar)) + sepsAfter <- focusAfterLoc (srcSpanEnd (getLoc pat)) (eachTokenLoc (replicate (arity - tag) AnnVbar)) + let locsBefore = map srcSpanEnd $ init sepsBefore + locsAfter = map srcSpanEnd sepsAfter + AST.UUnboxedSumPat <$> makeList " | " (after AnnOpen) (mapM makePlaceholder locsBefore) + <*> trfPattern pat + <*> makeList " | " (before AnnClose) (mapM makePlaceholder locsAfter) + where makePlaceholder l = annLocNoSema (pure (srcLocSpan l)) (pure AST.UUnboxedSumPlaceHolder) trfPattern' p = unhandledElement "pattern" p trfPatternField' :: TransformName n r => HsRecField n (LPat n) -> Trf (AST.UPatternField (Dom r) RangeStage)
Language/Haskell/Tools/BackendGHC/Stmts.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE LambdaCase - , ViewPatterns - , TypeFamilies - #-} +{-# LANGUAGE LambdaCase, TypeFamilies, ViewPatterns #-} -- | Functions that convert the statement-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Stmts where @@ -65,7 +62,7 @@ -> 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" + _ -> convertionProblem "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) @@ -78,4 +75,4 @@ getLastStmt :: [Located (Stmt n (LHsExpr n))] -> Located (HsExpr n) getLastStmt (L _ (LastStmt body _ _) : _) = body getLastStmt (_ : rest) = getLastStmt rest -getLastStmt [] = error "getLastStmt: empty" +getLastStmt [] = convProblem "getLastStmt: empty"
Language/Haskell/Tools/BackendGHC/TH.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE LambdaCase #-} + -- | 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.BackendGHC.TH where @@ -36,16 +36,17 @@ annLocNoSema (pure $ getSpliceLoc spls `mappend` rng) (trfSplice' spls) getSpliceLoc :: HsSplice a -> SrcSpan -getSpliceLoc (HsTypedSplice _ e) = getLoc e -getSpliceLoc (HsUntypedSplice _ e) = getLoc e +getSpliceLoc (HsTypedSplice _ _ e) = getLoc e +getSpliceLoc (HsUntypedSplice _ _ e) = getLoc e getSpliceLoc (HsQuasiQuote _ _ sp _) = sp getSpliceLoc (HsSpliced _ _) = noSrcSpan trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.USplice (Dom r) RangeStage) -trfSplice' (HsTypedSplice _ expr) = trfSpliceExpr expr -trfSplice' (HsUntypedSplice _ expr) = trfSpliceExpr expr +trfSplice' (HsTypedSplice _ _ expr) = trfSpliceExpr expr +trfSplice' (HsUntypedSplice _ _ expr) = trfSpliceExpr expr trfSplice' s = unhandledElement "splice" s +-- | TODO: easier with splice decoration trfSpliceExpr :: TransformName n r => Located (HsExpr n) -> Trf (AST.USplice (Dom r) RangeStage) trfSpliceExpr expr = do hasDollar <- allTokenLoc AnnThIdSplice
Language/Haskell/Tools/BackendGHC/Types.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE LambdaCase - , ViewPatterns - , ScopedTypeVariables - #-} +{-# LANGUAGE ScopedTypeVariables, ViewPatterns #-} -- | Functions that convert the type-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation module Language.Haskell.Tools.BackendGHC.Types where @@ -45,8 +42,8 @@ trfType'' (HsQualTy (L _ []) typ) = trfType' (unLoc typ) trfType'' (HsQualTy ctx typ) = AST.UTyCtx <$> (fromJust . (^. annMaybe) <$> trfCtx atTheStart ctx) <*> trfType typ - trfType'' (HsTyVar name) = AST.UTyVar <$> transformingPossibleVar name (trfName name) - trfType'' (HsAppsTy apps) | Just (head, args) <- getAppsTyHead_maybe apps + trfType'' (HsTyVar _ name) = AST.UTyVar <$> transformingPossibleVar name (trfName name) + trfType'' (HsAppsTy apps) | Just (head, args, _) <- getAppsTyHead_maybe apps = foldl (\core t -> AST.UTyApp <$> annLocNoSema (pure $ getLoc head `combineSrcSpans` getLoc t) core <*> trfType t) (trfType' (unLoc head)) args trfType'' (HsAppTy t1 t2) = AST.UTyApp <$> trfType t1 <*> trfType t2 trfType'' (HsFunTy t1 t2) = AST.UTyFun <$> trfType t1 <*> trfType t2 @@ -68,6 +65,7 @@ trfType'' pt@(HsExplicitTupleTy {}) = AST.UTyPromoted <$> annContNoSema (trfPromoted' trfType' pt) trfType'' pt@(HsTyLit {}) = AST.UTyPromoted <$> annContNoSema (trfPromoted' trfType' pt) trfType'' (HsWildCardTy _) = pure AST.UTyWildcard -- TODO: named wildcards + trfType'' (HsSumTy types) = AST.UUnbSumType <$> trfAnnList " | " trfType' types trfType'' t = unhandledElement "type" t trfBindings :: TransformName n r => [Located (HsTyVarBndr n)] -> Trf (AnnListG AST.UTyVar (Dom r) RangeStage) @@ -106,10 +104,9 @@ trfAssertion' (cleanHsType -> HsWildCardTy _) = pure AST.UWildcardAssert trfAssertion' (cleanHsType -> t) = case cleanHsType base of - HsTyVar name -> AST.UClassAssert <$> trfName name <*> trfAnnList " " trfType' args + HsTyVar _ name -> AST.UClassAssert <$> trfName name <*> trfAnnList " " trfType' args HsEqTy t1 t2 -> AST.UInfixAssert <$> trfType t1 <*> annLocNoSema (tokenLoc AnnTilde) (trfOperator' typeEq) <*> trfType t2 - HsIParamTy name t -> do loc <- tokenLoc AnnVal - AST.UImplicitAssert <$> define (focusOn loc (trfImplicitName name)) <*> trfType t + HsIParamTy name t -> AST.UImplicitAssert <$> define (focusOn (getLoc name) (trfImplicitName (unLoc name))) <*> trfType t t -> unhandledElement "assertion" t where (args, _, base) = getArgs t
Language/Haskell/Tools/BackendGHC/Utils.hs view
@@ -31,6 +31,7 @@ import Outputable (Outputable(..), showSDocUnsafe) import SrcLoc +import Control.Exception (Exception, throw) import Control.Monad.Reader import Control.Reference ((^.), (&)) import Data.Char (isSpace) @@ -51,10 +52,14 @@ let prelude = (xopt ImplicitPrelude $ ms_hspp_opts mod) && all (\idecl -> ("Prelude" /= (GHC.moduleNameString $ unLoc $ ideclName $ unLoc idecl)) || nameLoc == getLoc idecl) imports - (_,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) (ms_hspp_opts mod) (case ms_hsc_src mod of HsSrcFile -> False; _ -> True) preludeImports insts famInsts + (_, 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 ([], []) + -- This function (via getOrphanAndFamInstances) refers the ghc environment, + -- we must evaluate the result or the reference may be kept preventing garbage collection. + return $ mkModuleInfo (ms_mod mod) (ms_hspp_opts mod) (case ms_hsc_src mod of HsSrcFile -> False; _ -> True) + (forceElements preludeImports) (forceElements insts) (forceElements famInsts) -- | Creates a semantic information for a name createNameInfo :: n -> Trf (NameInfo n) @@ -80,7 +85,7 @@ createImplicitFldInfo select flds = return (mkImplicitFieldInfo (map getLabelAndExpr flds)) where getLabelAndExpr fld = ( getTheName $ unLoc (getFieldOccName (hsRecFieldLbl fld)) , getTheName $ select (hsRecFieldArg fld) ) - getTheName = (\case e:_ -> e; [] -> error "createImplicitFldInfo: missing names") . hsGetNames' + getTheName = (\case e:_ -> e; [] -> convProblem "createImplicitFldInfo: missing names") . hsGetNames' -- | Adds semantic information to an impord declaration. See ImportInfo. createImportData :: (GHCName r, HsHasName n) => GHC.ImportDecl n -> Trf (ImportInfo r) @@ -90,12 +95,18 @@ -- TODO: only use getFromNameUsing once lookedUpNames <- liftGhc $ mapM translatePName $ names lookedUpImported <- liftGhc $ mapM (getFromNameUsing getTopLevelId . (^. pName)) $ importedNames - (insts,famInsts) <- lift $ getOrphanAndFamInstances mod - return $ mkImportInfo mod (catMaybes lookedUpImported) (catMaybes lookedUpNames) insts famInsts + (insts, famInsts) <- lift $ getOrphanAndFamInstances mod + -- This function (via getOrphanAndFamInstances) refers the ghc environment, + -- we must evaluate the result or the reference may be kept preventing garbage collection. + return $ mkImportInfo mod (forceElements $ catMaybes lookedUpImported) + (forceElements $ catMaybes lookedUpNames) + (forceElements insts) (forceElements famInsts) where translatePName (PName n p) = do n' <- getFromNameUsing getTopLevelId n p' <- maybe (return Nothing) (getFromNameUsing getTopLevelId) p return (PName <$> n' <*> Just p') +-- | Gets the orphan and family instances from a module. +-- Important: the results must be evaluated or ghs session state will not be garbage-collected. getOrphanAndFamInstances :: Module -> Ghc ([ClsInst], [FamInst]) getOrphanAndFamInstances mod = do env <- getSession @@ -138,9 +149,19 @@ | otherwise = or @[] <$> mapM (`ieSpecMatches` name) (map unLoc (unLoc specs)) checkImportVisible _ _ = return True +-- | Forces strict evaluation of a list. Forces elements into WHNF. +forceElements :: [a] -> [a] +forceElements [] = [] +forceElements (a : ls) = let res = forceElements ls + in a `seq` res `seq` (a : ls) + ieSpecMatches :: (HsHasName name, GhcMonad m) => IE name -> GHC.Name -> m Bool ieSpecMatches (concatMap hsGetNames' . HsSyn.ieNames -> ls) name | name `elem` ls = return True +-- ieNames does not consider field names +ieSpecMatches (IEThingWith thing _ with flds) name + | name `elem` concatMap hsGetNames' (map (ieWrappedName . unLoc) (thing : with) ++ map (flSelector . unLoc) flds) + = return True ieSpecMatches ie@(IEThingAll _) name | [n] <- hsGetNames' (HsSyn.ieName ie), isTyConName n = do entity <- lookupName n return $ case entity of Just (ATyCon tc) @@ -275,6 +296,12 @@ updateFocus f trf = do newSpan <- f =<< asks contRange focusOn newSpan trf +focusAfterLoc :: SrcLoc -> Trf a -> Trf a +focusAfterLoc loc = local (\s -> s { contRange = mkSrcSpan loc (srcSpanEnd (contRange s)) }) + +focusBeforeLoc :: SrcLoc -> Trf a -> Trf a +focusBeforeLoc loc = local (\s -> s { contRange = mkSrcSpan (srcSpanStart (contRange s)) loc }) + -- | Focuses the transformation to go between tokens. The tokens must be found inside the current range. between :: AnnKeywordId -> AnnKeywordId -> Trf a -> Trf a between firstTok lastTok = focusAfter firstTok . focusBefore lastTok @@ -290,7 +317,7 @@ if (isGoodSrcSpan firstToken) then local (\s -> s { contRange = mkSrcSpan (srcSpanEnd firstToken) (srcSpanEnd (contRange s))}) trf else do rng <- asks contRange - error $ "focusAfter: token not found in " ++ show rng ++ ": " ++ show firstTok + convertionProblem $ "focusAfter: token not found in " ++ show rng ++ ": " ++ show firstTok focusAfterIfPresent :: AnnKeywordId -> Trf a -> Trf a focusAfterIfPresent firstTok trf @@ -306,7 +333,7 @@ if (isGoodSrcSpan lastToken) then local (\s -> s { contRange = mkSrcSpan (srcSpanStart (contRange s)) (srcSpanStart lastToken)}) trf else do rng <- asks contRange - error $ "focusBefore: token not found in " ++ show rng ++ ": " ++ show lastTok + convertionProblem $ "focusBefore: token not found in " ++ show rng ++ ": " ++ show lastTok focusBeforeIfPresent :: AnnKeywordId -> Trf a -> Trf a focusBeforeIfPresent lastTok trf @@ -363,14 +390,16 @@ -- | Searches for tokens in the given order inside the parent element and returns their combined location tokensLoc :: [AnnKeywordId] -> Trf SrcSpan -tokensLoc keys = asks contRange >>= tokensLoc' keys - where tokensLoc' :: [AnnKeywordId] -> SrcSpan -> Trf SrcSpan - tokensLoc' (keyw:rest) r - = do spanFirst <- tokenLoc keyw - spanRest <- tokensLoc' rest (mkSrcSpan (srcSpanEnd spanFirst) (srcSpanEnd r)) - return (combineSrcSpans spanFirst spanRest) - tokensLoc' [] _ = pure noSrcSpan +tokensLoc keys = foldLocs <$> eachTokenLoc keys +-- | Searches for tokens in the given order inside the parent element and returns their location +eachTokenLoc :: [AnnKeywordId] -> Trf [SrcSpan] +eachTokenLoc (keyw:rest) + = do spanFirst <- tokenLoc keyw + spanRest <- focusAfterLoc (srcSpanEnd spanFirst) (eachTokenLoc rest) + return (spanFirst : spanRest) +eachTokenLoc [] = pure [] + -- | Searches for a token and retrieves its location anywhere uniqueTokenAnywhere :: AnnKeywordId -> Trf SrcSpan uniqueTokenAnywhere keyw = fromMaybe noSrcSpan <$> (getKeywordAnywhere keyw <$> asks srcMap) @@ -426,6 +455,10 @@ removeDuplicates (fst:rest) = fst : removeDuplicates (filter ((/= getLoc fst) . getLoc) rest) removeDuplicates [] = [] +-- | Orders a list of elements to the order they are defined in the source file. +orderLocated :: [Located e] -> [Located e] +orderLocated = sortBy (compare `on` getLoc) + -- | 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) @@ -433,16 +466,20 @@ -- | Splits a given string at whitespaces while calculating the source location of the fragments splitLocated :: Located String -> [Located String] -splitLocated (L (RealSrcSpan l) str) = splitLocated' str (realSrcSpanStart l) Nothing +splitLocated = splitLocatedOn isSpace + +-- | Splits a given string while calculating the source location of the fragments +splitLocatedOn :: (Char -> Bool) -> Located String -> [Located String] +splitLocatedOn pred (L (RealSrcSpan l) str) = splitLocated' str (realSrcSpanStart l) Nothing where splitLocated' :: String -> RealSrcLoc -> Maybe (RealSrcLoc, String) -> [Located String] - splitLocated' (c:rest) currLoc (Just (startLoc, str)) | isSpace c + splitLocated' (c:rest) currLoc (Just (startLoc, str)) | pred c = L (RealSrcSpan $ mkRealSrcSpan startLoc currLoc) (reverse str) : splitLocated' rest (advanceSrcLoc currLoc c) Nothing - splitLocated' (c:rest) currLoc Nothing | isSpace c = splitLocated' rest (advanceSrcLoc currLoc c) Nothing + splitLocated' (c:rest) currLoc Nothing | pred c = splitLocated' rest (advanceSrcLoc currLoc c) Nothing 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' [] _ Nothing = [] -splitLocated _ = error "splitLocated: unhelpful span given" +splitLocatedOn _ _ = convProblem "splitLocated: unhelpful span given" compareSpans :: SrcSpan -> SrcSpan -> Ordering compareSpans (RealSrcSpan a) (RealSrcSpan b) @@ -452,15 +489,26 @@ -- | Report errors when cannot convert a type of element unhandledElement :: (Data a, Outputable a) => String -> a -> Trf b -unhandledElement label e = do rng <- asks contRange - error ("Illegal " ++ label ++ ": " ++ showSDocUnsafe (ppr e) ++ " (ctor: " ++ show (toConstr e) ++ ") at: " ++ show rng) +unhandledElement label e = convertionProblem ("Illegal " ++ label ++ ": " ++ showSDocUnsafe (ppr e) ++ " (ctor: " ++ show (toConstr e) ++ ")") unhandledElementNoPpr :: (Data a) => String -> a -> Trf b -unhandledElementNoPpr label e = do rng <- asks contRange - error ("Illegal " ++ label ++ ": (ctor: " ++ show (toConstr e) ++ ") at: " ++ show rng) +unhandledElementNoPpr label e = convertionProblem ("Illegal " ++ label ++ ": (ctor: " ++ show (toConstr e) ++ ")") instance Monoid SrcSpan where span1@(RealSrcSpan _) `mappend` _ = span1 _ `mappend` span2 = span2 mempty = noSrcSpan + +data ConvertionProblem = ConvertionProblem SrcSpan String + | UnrootedConvertionProblem String + deriving Show + +instance Exception ConvertionProblem + +convertionProblem :: String -> Trf a +convertionProblem msg = do rng <- asks contRange + throw $ ConvertionProblem rng msg + +convProblem :: String -> a +convProblem = throw . UnrootedConvertionProblem
haskell-tools-backend-ghc.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-backend-ghc -version: 0.9.0.0 +version: 1.0.0.0 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 @@ -31,7 +31,7 @@ , Language.Haskell.Tools.BackendGHC.SourceMap , Language.Haskell.Tools.BackendGHC.AddTypeInfo - build-depends: base >= 4.9 && < 4.10 + build-depends: base >= 4.10 && < 4.11 , transformers >= 0.5 && < 0.6 , references >= 0.3 && < 0.4 , bytestring >= 0.10 && < 0.11 @@ -40,8 +40,8 @@ , containers >= 0.5 && < 0.6 , mtl >= 2.2 && < 2.3 , split >= 0.2 && < 0.3 - , template-haskell >= 2.11 && < 2.12 - , ghc >= 8.0 && < 8.1 - , haskell-tools-ast >= 0.9 && < 0.10 - , ghc-boot-th >= 8.0 && < 8.1 + , template-haskell >= 2.12 && < 2.13 + , ghc >= 8.2 && < 8.3 + , haskell-tools-ast >= 1.0 && < 1.1 + , ghc-boot-th >= 8.2 && < 8.3 default-language: Haskell2010