diff --git a/Language/Haskell/Tools/BackendGHC/AddTypeInfo.hs b/Language/Haskell/Tools/BackendGHC/AddTypeInfo.hs --- a/Language/Haskell/Tools/BackendGHC/AddTypeInfo.hs +++ b/Language/Haskell/Tools/BackendGHC/AddTypeInfo.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase, ScopedTypeVariables, TupleSections #-} + module Language.Haskell.Tools.BackendGHC.AddTypeInfo (addTypeInfos) where import Bag as GHC (bagToList) @@ -28,7 +29,7 @@ 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.AST.SemaInfoTypes as AST import Language.Haskell.Tools.BackendGHC.GHCUtils (getTopLevelId) import Language.Haskell.Tools.BackendGHC.Utils (ConvertionProblem(..), forceElements, convProblem) @@ -55,13 +56,37 @@ ((_,id):more) -> do put (none ++ more) return $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) id _ -> convProblem "addTypeInfos: Cannot access a the semantics of a name.") - pure (traverse (lift . getType)) (traverse (lift . getType)) pure + pure fetchLitType (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 getType' ut name = fromMaybe (mkVanillaGlobal name ut) <$> ((<|> Map.lookup name ids) <$> getTopLevelId name) ids = Map.fromList $ map (\id -> (getName id, id)) $ extractTypes bnds + extractTypes :: LHsBinds Id -> [Id] extractTypes = concatMap universeBi . bagToList + + fetchLitType :: Monad m => PreLiteralInfo -> m LiteralInfo + fetchLitType (RealLiteralInfo t) = return $ LiteralInfo t + fetchLitType (PreLiteralInfo sp) = return $ LiteralInfo $ fromMaybe (convProblem $ "cannot lookup type of literal at: " ++ shortShowSpanWithFile sp) $ lookup sp decompedOverloadedLits + + -- NOTE: Only overloaded literals' type information is collected here + -- Might not be complete + -- Collecting only HsOverLits doesn't work, + -- because they contain only UnhelpfulSrcSpans + decompedOverloadedLits :: [(SrcSpan, Type)] + decompedOverloadedLits = catMaybes $ map decompExprLit exprLits ++ map decompPatLit patLits + where exprLits :: [LHsExpr Id] + exprLits = concatMap universeBi . bagToList $ bnds + + decompExprLit (L loc (HsOverLit lit)) = Just (loc, ol_type lit) + decompExprLit x = Nothing + + patLits :: [LPat Id] + patLits = concatMap universeBi . bagToList $ bnds + + decompPatLit (L loc (NPat llit _ _ _)) = Just (loc, ol_type . unLoc $ llit) + decompPatLit x = Nothing + mkUnknownType :: IO Type mkUnknownType = do diff --git a/Language/Haskell/Tools/BackendGHC/Binds.hs b/Language/Haskell/Tools/BackendGHC/Binds.hs --- a/Language/Haskell/Tools/BackendGHC/Binds.hs +++ b/Language/Haskell/Tools/BackendGHC/Binds.hs @@ -1,4 +1,5 @@ {-# 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 @@ -15,6 +16,7 @@ import Control.Monad.Reader (Monad(..), mapM, asks) import Data.List +import Data.Function (on) import Language.Haskell.Tools.BackendGHC.Exprs (trfExpr) import Language.Haskell.Tools.BackendGHC.GHCUtils (occName, fromSrcText) @@ -160,7 +162,7 @@ then makeJust <$> (annLocNoSema (return precLoc) $ pure $ AST.Precedence prec) -- names cannot be empty else nothing "" " " (return $ srcSpanStart $ getLoc $ head names)) - <*> (nonemptyAnnList . nub <$> mapM trfOperator names) + <*> (nonemptyAnnList . nubBy ((==) `on` AST.getRange) <$> mapM trfOperator names) where transformDir InfixL = directionChar (pure AST.AssocLeft) transformDir InfixR = directionChar (pure AST.AssocRight) transformDir InfixN = annLocNoSema (srcLocSpan . srcSpanEnd <$> tokenLoc AnnInfix) (pure AST.AssocNone) diff --git a/Language/Haskell/Tools/BackendGHC/Decls.hs b/Language/Haskell/Tools/BackendGHC/Decls.hs --- a/Language/Haskell/Tools/BackendGHC/Decls.hs +++ b/Language/Haskell/Tools/BackendGHC/Decls.hs @@ -1,4 +1,5 @@ {-# 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 @@ -98,14 +99,14 @@ 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 + case allLocals of locals:_ -> liftGhc $ mapM (replaceNamesInDecls (map (^. _1) locals)) decls [] -> 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 (convProblem $ "Data definition name not found: " ++ showSDocUnsafe (ppr rdr) - ++ ", locals: " ++ (concat $ intersperse ", " $ map (showSDocUnsafe . ppr) locals)) - $ find ((occNameString (rdrNameOcc rdr) ==) . occNameString . nameOccName) locals + where replaceNamesInDecls :: [GHC.Name] -> Ann AST.UDecl (Dom RdrName) RangeStage -> GHC.Ghc (Ann AST.UDecl (Dom r) RangeStage) + replaceNamesInDecls locals = AST.semaTraverse $ + AST.SemaTrf (pure . (AST.nameInfo .- findName)) pure pure (pure . fmap findName) pure pure pure + where findName rdr = 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 diff --git a/Language/Haskell/Tools/BackendGHC/Exprs.hs b/Language/Haskell/Tools/BackendGHC/Exprs.hs --- a/Language/Haskell/Tools/BackendGHC/Exprs.hs +++ b/Language/Haskell/Tools/BackendGHC/Exprs.hs @@ -1,4 +1,5 @@ {-# 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 @@ -14,10 +15,10 @@ import PrelNames as GHC (negateName) import SrcLoc as GHC -import Language.Haskell.Tools.AST.SemaInfoTypes (ScopeInfo, mkScopeInfo) +import Language.Haskell.Tools.AST.SemaInfoTypes import {-# SOURCE #-} Language.Haskell.Tools.BackendGHC.Binds (trfRhsGuard', trfWhereLocalBinds, trfLocalBinds) import Language.Haskell.Tools.BackendGHC.GHCUtils (GHCName(..), getFieldOccName) -import Language.Haskell.Tools.BackendGHC.Literals (trfLiteral', trfOverloadedLit) +import Language.Haskell.Tools.BackendGHC.Literals import Language.Haskell.Tools.BackendGHC.Monad import Language.Haskell.Tools.BackendGHC.Names import Language.Haskell.Tools.BackendGHC.Patterns (trfPattern) @@ -62,8 +63,8 @@ trfExpr' (HsUnboundVar name) = AST.UVar <$> trfNameText (occNameString $ unboundVarOcc name) trfExpr' (HsRecFld fld) = AST.UVar <$> (asks contRange >>= \l -> trfAmbiguousFieldName' l fld) trfExpr' (HsIPVar ip) = AST.UVar <$> trfImplicitName ip -trfExpr' (HsOverLit (ol_val -> val)) = AST.ULit <$> annContNoSema (trfOverloadedLit val) -trfExpr' (HsLit val) = AST.ULit <$> annContNoSema (trfLiteral' val) +trfExpr' (HsOverLit (ol_val -> val)) = AST.ULit <$> annCont (asks contRange >>= pure . PreLiteralInfo) (trfOverloadedLit val) +trfExpr' (HsLit val) = AST.ULit <$> annCont (pure $ RealLiteralInfo (monoLiteralType val)) (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 <$> addToScope matches (trfAnnList " " trfAlt' matches) diff --git a/Language/Haskell/Tools/BackendGHC/GHCUtils.hs b/Language/Haskell/Tools/BackendGHC/GHCUtils.hs --- a/Language/Haskell/Tools/BackendGHC/GHCUtils.hs +++ b/Language/Haskell/Tools/BackendGHC/GHCUtils.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase, RecordWildCards, ScopedTypeVariables #-} + -- | Utility functions defined on the GHC AST representation. module Language.Haskell.Tools.BackendGHC.GHCUtils where diff --git a/Language/Haskell/Tools/BackendGHC/Kinds.hs b/Language/Haskell/Tools/BackendGHC/Kinds.hs --- a/Language/Haskell/Tools/BackendGHC/Kinds.hs +++ b/Language/Haskell/Tools/BackendGHC/Kinds.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TypeFamilies, ViewPatterns #-} +{-# LANGUAGE GADTs, 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 diff --git a/Language/Haskell/Tools/BackendGHC/Literals.hs b/Language/Haskell/Tools/BackendGHC/Literals.hs --- a/Language/Haskell/Tools/BackendGHC/Literals.hs +++ b/Language/Haskell/Tools/BackendGHC/Literals.hs @@ -6,25 +6,39 @@ import BasicTypes as GHC (FractionalLit(..)) import FastString as GHC (unpackFS) import HsLit as GHC (OverLitVal(..), HsLit(..)) +import Type as GHC +import TysWiredIn as GHC +import TysPrim as GHC import Language.Haskell.Tools.AST (Dom, RangeStage) import qualified Language.Haskell.Tools.AST as AST (ULiteral(..)) import Language.Haskell.Tools.BackendGHC.Monad (Trf) +import Language.Haskell.Tools.BackendGHC.Utils trfLiteral' :: HsLit -> Trf (AST.ULiteral (Dom r) RangeStage) trfLiteral' (HsChar _ ch) = pure $ AST.UCharLit ch trfLiteral' (HsCharPrim _ ch) = pure $ AST.UPrimCharLit ch trfLiteral' (HsString _ str) = pure $ AST.UStringLit (unpackFS str) trfLiteral' (HsStringPrim _ str) = pure $ AST.UPrimStringLit (BS.foldr (:) "" str) -trfLiteral' (HsInt _ i) = pure $ AST.UIntLit i trfLiteral' (HsIntPrim _ i) = pure $ AST.UPrimIntLit i trfLiteral' (HsWordPrim _ i) = pure $ AST.UPrimWordLit i trfLiteral' (HsInt64Prim _ i) = pure $ AST.UPrimIntLit i trfLiteral' (HsWord64Prim _ i) = pure $ AST.UPrimWordLit i -trfLiteral' (HsInteger _ i _) = pure $ AST.UPrimIntLit i -trfLiteral' (HsRat frac _) = pure $ AST.UFracLit (fl_value frac) trfLiteral' (HsFloatPrim frac) = pure $ AST.UPrimFloatLit (fl_value frac) trfLiteral' (HsDoublePrim frac) = pure $ AST.UPrimDoubleLit (fl_value frac) +trfLiteral' l = unhandledElement "literal" l + +monoLiteralType :: HsLit -> Type +monoLiteralType (HsChar _ _) = charTy +monoLiteralType (HsCharPrim _ _) = charPrimTy +monoLiteralType (HsString _ _) = stringTy +monoLiteralType (HsStringPrim _ _) = addrPrimTy +monoLiteralType (HsIntPrim _ _) = intPrimTy +monoLiteralType (HsWordPrim _ _) = wordTy +monoLiteralType (HsInt64Prim _ _) = int64PrimTy +monoLiteralType (HsWord64Prim _ _) = word64PrimTy +monoLiteralType (HsFloatPrim _) = floatX4PrimTy +monoLiteralType (HsDoublePrim _) = doubleX2PrimTy trfOverloadedLit :: OverLitVal -> Trf (AST.ULiteral (Dom r) RangeStage) trfOverloadedLit (HsIntegral _ i) = pure $ AST.UIntLit i diff --git a/Language/Haskell/Tools/BackendGHC/Modules.hs b/Language/Haskell/Tools/BackendGHC/Modules.hs --- a/Language/Haskell/Tools/BackendGHC/Modules.hs +++ b/Language/Haskell/Tools/BackendGHC/Modules.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, LambdaCase, ScopedTypeVariables, TypeApplications, TypeFamilies, ViewPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleContexts, GADTs, LambdaCase, MultiWayIf, ScopedTypeVariables, TypeApplications, 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.Monad.State import Control.Reference hiding (element) import Data.Char (isSpace) import Data.Generics.Uniplate.Data () @@ -21,7 +23,7 @@ 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 (nameInfo, implicitNames, importedNames) +import Language.Haskell.Tools.AST.SemaInfoTypes as AST import Language.Haskell.Tools.BackendGHC.Decls (trfDecls, trfDeclsGroup) import Language.Haskell.Tools.BackendGHC.Exprs (trfText') import Language.Haskell.Tools.BackendGHC.Monad @@ -53,7 +55,7 @@ !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) + originalNames = Map.fromList $ mapMaybe getSourceAndInfo (rangeMod ^? biplateRef) getSourceAndInfo :: Ann AST.UQualifiedName (Dom RdrName) RangeStage -> Maybe (SrcSpan, RdrName) getSourceAndInfo n = (,) <$> (n ^? annotation&sourceInfo&nodeSpan) <*> (n ^? semantics&nameInfo) @@ -95,8 +97,8 @@ loadSplices :: HsModule RdrName -> Trf a -> Trf a loadSplices hsMod trf = do let declSpls = map (\(SpliceDecl sp _) -> sp) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)] - exprSpls = catMaybes $ map (\case L l (HsSpliceE sp) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)] - typeSpls = catMaybes $ map (\case L l (HsSpliceTy sp _) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)] + exprSpls = mapMaybe (\case L l (HsSpliceE sp) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)] + typeSpls = mapMaybe (\case L l (HsSpliceTy sp _) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)] setSplices declSpls typeSpls exprSpls trf trfModuleHead :: TransformName n r => Maybe (Located ModuleName) -> SrcLoc -> Maybe (Located [LIE n]) -> Maybe (Located WarningTxt) -> Trf (AnnMaybeG AST.UModuleHead (Dom r) RangeStage) @@ -144,22 +146,27 @@ other -> do trf <- trfIESpec' other fmap AST.UDeclExport <$> (sequence $ fmap (annContNoSema . return) trf) -trfImports :: TransformName n r => [LImportDecl n] -> Trf (AnnListG AST.UImportDecl (Dom r) RangeStage) +trfImports :: forall n r . TransformName n r => [LImportDecl n] -> Trf (AnnListG AST.UImportDecl (Dom r) RangeStage) trfImports (filter (not . ideclImplicit . unLoc) -> imps) - = AnnListG <$> importDefaultLoc <*> mapM trfImport imps + = do res <- AnnListG <$> importDefaultLoc <*> mapM trfImport imps + -- the list of imported entities is added after the imports have been evaluated, to have all instances loaded + !importData <- mapM (createImportData . unLoc) imps :: Trf [ImportInfo r] + return $ flip evalState 0 $ AST.annList & AST.annotation & AST.semanticInfo + !~ (\_ -> get >>= \i -> modify (+1) >> return (importData !! i)) $ res where importDefaultLoc = noSemaInfo . AST.ListPos (if List.null imps then "\n" else "") "" "\n" (Just []) . srcSpanEnd <$> (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 _ name pkg isSrc _ isQual _ declAs declHiding)) = focusOn l $ +trfImport (L l (GHC.ImportDecl _ name pkg isSrc _ isQual _ declAs declHiding)) = focusOn l $ do safeTok <- tokenLoc AnnSafe let -- default positions of optional parts of an import declaration annBeforeQual = if isSrc then AnnClose else AnnImport annBeforeSafe = if isQual then AnnQualified else annBeforeQual annBeforePkg = if isGoodSrcSpan safeTok then AnnSafe else annBeforeSafe - - !importData <- createImportData impDecl - annLoc (pure importData) (pure l) $ AST.UImportDecl + -- the import semantic infos will be generated after all imports are processed, + -- otherwise information on instances imported will be inconsistent + annLoc (pure (error "Import's semantic data not initialized")) (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)) @@ -205,8 +212,10 @@ 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 + typLoc <- tokenLoc AnnType + if | (not . isGoodSrcSpan $ patLoc) && (not . isGoodSrcSpan $ typLoc) -> nothing " " "" atTheStart + | isGoodSrcSpan patLoc -> makeJust <$> annLocNoSema (return patLoc) (return AST.UImportPattern) + | isGoodSrcSpan typLoc -> makeJust <$> annLocNoSema (return typLoc) (return AST.UImportType) trfModuleName :: Located ModuleName -> Trf (Ann AST.UModuleName (Dom r) RangeStage) trfModuleName = trfLocNoSema trfModuleName' diff --git a/Language/Haskell/Tools/BackendGHC/Names.hs b/Language/Haskell/Tools/BackendGHC/Names.hs --- a/Language/Haskell/Tools/BackendGHC/Names.hs +++ b/Language/Haskell/Tools/BackendGHC/Names.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE AllowAmbiguousTypes, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, 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 @@ -53,11 +54,10 @@ trfAmbiguousOperator' :: forall n r . TransformName n r => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.UOperator (Dom r) RangeStage) trfAmbiguousOperator' l (Unambiguous (L _ rdr) pr) = annLocNoSema (pure l) $ trfOperator' (unpackPostRn @n rdr pr) -- no Id transformation is done, so we can basically ignore the postTC value -trfAmbiguousFieldOperator' _ (Ambiguous (L l rdr) _) +trfAmbiguousOperator' _ (Ambiguous (L l rdr) _) = annLocNoSema (pure l) $ (if (isSymOcc (occName rdr)) then AST.UNormalOp else AST.UBacktickOp) <$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfOperatorStr (not $ isSymOcc (occName rdr)) (rdrNameStr rdr)) - class (DataId n, Eq n, GHCName n, FromGHCName n, NameOrRdrName n ~ n, HasOccName n) => TransformableName n where correctNameString :: n -> Trf String diff --git a/Language/Haskell/Tools/BackendGHC/Patterns.hs b/Language/Haskell/Tools/BackendGHC/Patterns.hs --- a/Language/Haskell/Tools/BackendGHC/Patterns.hs +++ b/Language/Haskell/Tools/BackendGHC/Patterns.hs @@ -1,4 +1,5 @@ {-# 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 @@ -11,10 +12,12 @@ import HsTypes as GHC (HsWildCardBndrs(..), HsImplicitBndrs(..), HsConDetails(..)) import Language.Haskell.Tools.BackendGHC.GHCUtils (getFieldOccName) import SrcLoc as GHC +import Control.Monad.Reader import {-# SOURCE #-} Language.Haskell.Tools.BackendGHC.Exprs (trfExpr) -import Language.Haskell.Tools.BackendGHC.Literals (trfLiteral', trfOverloadedLit) -import Language.Haskell.Tools.BackendGHC.Monad (Trf, define) +import Language.Haskell.Tools.AST.SemaInfoTypes +import Language.Haskell.Tools.BackendGHC.Literals +import Language.Haskell.Tools.BackendGHC.Monad import Language.Haskell.Tools.BackendGHC.Names (TransformName(..), trfOperator, trfName) import {-# SOURCE #-} Language.Haskell.Tools.BackendGHC.TH (trfSplice, trfQuasiQuotation') import Language.Haskell.Tools.BackendGHC.Types (trfType) @@ -56,10 +59,10 @@ trfPattern' (ViewPat expr pat _) = AST.UViewPat <$> trfExpr expr <*> trfPattern pat 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' (LitPat lit) = AST.ULitPat <$> annCont (pure $ RealLiteralInfo (monoLiteralType lit)) (trfLiteral' lit) 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' (NPat (ol_val . unLoc -> lit) _ _ _) = AST.ULitPat <$> annCont (asks contRange >>= pure . PreLiteralInfo) (trfOverloadedLit lit) +trfPattern' (NPlusKPat id (L l lit) _ _ _ _) = AST.UNPlusKPat <$> define (trfName id) <*> annLoc (asks contRange >>= pure . PreLiteralInfo) (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)) diff --git a/Language/Haskell/Tools/BackendGHC/SourceMap.hs b/Language/Haskell/Tools/BackendGHC/SourceMap.hs --- a/Language/Haskell/Tools/BackendGHC/SourceMap.hs +++ b/Language/Haskell/Tools/BackendGHC/SourceMap.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TupleSections #-} + -- | A representation of the tokens that build up the source file. module Language.Haskell.Tools.BackendGHC.SourceMap where diff --git a/Language/Haskell/Tools/BackendGHC/Stmts.hs b/Language/Haskell/Tools/BackendGHC/Stmts.hs --- a/Language/Haskell/Tools/BackendGHC/Stmts.hs +++ b/Language/Haskell/Tools/BackendGHC/Stmts.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase, TypeFamilies, ViewPatterns #-} +{-# LANGUAGE GADTs, LambdaCase, 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 diff --git a/Language/Haskell/Tools/BackendGHC/Types.hs b/Language/Haskell/Tools/BackendGHC/Types.hs --- a/Language/Haskell/Tools/BackendGHC/Types.hs +++ b/Language/Haskell/Tools/BackendGHC/Types.hs @@ -1,4 +1,5 @@ {-# 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 diff --git a/Language/Haskell/Tools/BackendGHC/Utils.hs b/Language/Haskell/Tools/BackendGHC/Utils.hs --- a/Language/Haskell/Tools/BackendGHC/Utils.hs +++ b/Language/Haskell/Tools/BackendGHC/Utils.hs @@ -1,21 +1,12 @@ -- | Utility functions for transforming the GHC AST representation into our own. -{-# LANGUAGE TypeSynonymInstances - , FlexibleInstances - , LambdaCase - , ViewPatterns - , MultiParamTypeClasses - , FlexibleContexts - , AllowAmbiguousTypes - , TypeApplications - , TypeFamilies - #-} +{-# LANGUAGE AllowAmbiguousTypes, FlexibleContexts, GADTs, LambdaCase, TypeApplications, ViewPatterns #-} + module Language.Haskell.Tools.BackendGHC.Utils where import ApiAnnotation (AnnKeywordId) import Avail (availNamesWithSelectors, availNames, availName) 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) @@ -23,12 +14,14 @@ import GHC import HsSyn import HscTypes -import Id (idName) -import InstEnv as GHC (ClsInst(..), instanceDFunId, instEnvElts) +import Var +import InstEnv as GHC (ClsInst(..), instEnvElts) import Language.Haskell.TH.LanguageExtensions (Extension(..)) import Module as GHC import Name import Outputable (Outputable(..), showSDocUnsafe) +import Packages +import Finder import SrcLoc import Control.Exception (Exception, throw) @@ -36,7 +29,6 @@ import Control.Reference ((^.), (&)) import Data.Char (isSpace) import Data.Data (Data(..)) -import Data.Either (Either(..), rights, lefts) import Data.Function hiding ((&)) import Data.IORef (readIORef) import Data.List @@ -53,13 +45,12 @@ && 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 ([], []) - -- This function (via getOrphanAndFamInstances) refers the ghc environment, + deps <- if prelude then lift $ getDeps (Module baseUnitId (GHC.mkModuleName "Prelude")) + else return [] + -- This function (via getInstances) 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) + (forceElements preludeImports) deps -- | Creates a semantic information for a name createNameInfo :: n -> Trf (NameInfo n) @@ -95,38 +86,30 @@ -- TODO: only use getFromNameUsing once lookedUpNames <- liftGhc $ mapM translatePName $ names lookedUpImported <- liftGhc $ mapM (getFromNameUsing getTopLevelId . (^. pName)) $ importedNames - (insts, famInsts) <- lift $ getOrphanAndFamInstances mod - -- This function (via getOrphanAndFamInstances) refers the ghc environment, + deps <- lift $ getDeps mod + -- This function (via getInstances) 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) + deps 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 - 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) - +getDeps :: Module -> Ghc [Module] +getDeps mod = do + env <- GHC.getSession + eps <- liftIO $ hscEPS env + case lookupIfaceByModule (hsc_dflags env) (hsc_HPT env) (eps_PIT eps) mod of + Just ifc -> (mod :) <$> mapM (liftIO . getModule env . fst) (dep_mods (mi_deps ifc)) + Nothing -> return [mod] + where getModule env modName = do + res <- findHomeModule env modName + case res of Found _ m -> return m + _ -> case lookupPluginModuleWithSuggestions (hsc_dflags env) modName Nothing of + LookupFound m _ -> return m + LookupHidden hiddenPack hiddenMod -> return (head $ map fst hiddenMod ++ map fst hiddenPack) + _ -> error $ "getDeps: module not found: " ++ GHC.moduleNameString modName -- | Get names that are imported from a given import getImportedNames :: String -> Maybe String -> Trf (GHC.Module, [PName GHC.Name]) diff --git a/haskell-tools-backend-ghc.cabal b/haskell-tools-backend-ghc.cabal --- a/haskell-tools-backend-ghc.cabal +++ b/haskell-tools-backend-ghc.cabal @@ -1,5 +1,5 @@ name: haskell-tools-backend-ghc -version: 1.0.0.4 +version: 1.0.1.1 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