haskell-tools-backend-ghc (empty) → 0.3.0.0

raw patch · 23 files changed

+2708/−0 lines, 23 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, ghc, haskell-tools-ast, mtl, references, safe, split, template-haskell, transformers, uniplate

Files

LICENSE +29/−0
Language/Haskell/Tools/AST/FromGHC.hs +9/−0
Language/Haskell/Tools/AST/FromGHC/AddTypeInfo.hs +95/−0
Language/Haskell/Tools/AST/FromGHC/Binds.hs +142/−0
Language/Haskell/Tools/AST/FromGHC/Binds.hs-boot +17/−0
Language/Haskell/Tools/AST/FromGHC/Decls.hs +516/−0
Language/Haskell/Tools/AST/FromGHC/Exprs.hs +229/−0
Language/Haskell/Tools/AST/FromGHC/Exprs.hs-boot +15/−0
Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs +216/−0
Language/Haskell/Tools/AST/FromGHC/Kinds.hs +66/−0
Language/Haskell/Tools/AST/FromGHC/Literals.hs +38/−0
Language/Haskell/Tools/AST/FromGHC/Modules.hs +250/−0
Language/Haskell/Tools/AST/FromGHC/Monad.hs +117/−0
Language/Haskell/Tools/AST/FromGHC/Names.hs +145/−0
Language/Haskell/Tools/AST/FromGHC/Patterns.hs +71/−0
Language/Haskell/Tools/AST/FromGHC/SourceMap.hs +61/−0
Language/Haskell/Tools/AST/FromGHC/Stmts.hs +81/−0
Language/Haskell/Tools/AST/FromGHC/TH.hs +60/−0
Language/Haskell/Tools/AST/FromGHC/TH.hs-boot +16/−0
Language/Haskell/Tools/AST/FromGHC/Types.hs +120/−0
Language/Haskell/Tools/AST/FromGHC/Utils.hs +368/−0
Setup.hs +2/−0
haskell-tools-backend-ghc.cabal +45/−0

+ LICENSE view

@@ -0,0 +1,29 @@+Haskell-Tools is Copyright (c) Boldizsár Németh, 2016, all rights reserved,
+and is distributed as free software under the following license.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+- Redistributions of source code must retain the above copyright
+notice, this list of conditions, and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions, and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+- The names of the copyright holders may not be used to endorse or
+promote products derived from this software without specific prior
+written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Language/Haskell/Tools/AST/FromGHC.hs view

@@ -0,0 +1,9 @@+-- | 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.AST.FromGHC 
+  ( trfModule, trfModuleRename, addTypeInfos, runTrf ) where
+
+import Language.Haskell.Tools.AST.FromGHC.Modules
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.AddTypeInfo

+ Language/Haskell/Tools/AST/FromGHC/AddTypeInfo.hs view

@@ -0,0 +1,95 @@+{-# LANGUAGE TupleSections 
+           , LambdaCase 
+           , ScopedTypeVariables
+           #-}
+module Language.Haskell.Tools.AST.FromGHC.AddTypeInfo (addTypeInfos) where
+
+import GHC
+import OccName as GHC hiding (varName)
+import TcEvidence as GHC
+import Bag as GHC
+import Unique as GHC
+import UniqFM as GHC
+import HscTypes as GHC
+import Module as GHC
+import TysWiredIn as GHC
+import Type as GHC
+import UniqSupply as GHC
+import Name as GHC hiding (varName)
+import Var as GHC
+import Id as GHC
+import SrcLoc as GHC
+
+import Data.Maybe
+import Data.List as List
+import qualified Data.Map as Map
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.State
+import Control.Applicative
+import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.Data
+
+import Language.Haskell.Tools.AST as AST
+import Language.Haskell.Tools.AST.SemaInfoTypes as AST
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+
+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
+  let createCName sc def id = mkCNameInfo sc def id fixity
+        where fixity = if any (any ((getOccName id ==) . getOccName)) (init sc) 
+                          then Nothing 
+                          else fmap (snd . snd) $ List.find (\(mod,(occ,_)) -> mod == (nameModule $ varName id) && occ == getOccName id) fixities
+  evalStateT (semaTraverse 
+    (AST.SemaTrf
+      (\ni -> case (AST.semanticsSourceInfo ni, AST.semanticsName ni) of 
+                (_, Just name) -> lift $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) <$> getType name
+                (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
+                                                 ((_,id):more) -> do put (none ++ more)
+                                                                     return $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) id)
+      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
+        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
+
+        mkUnknownType :: IO Type
+        mkUnknownType = do 
+          tUnique <- mkSplitUniqSupply 'x'
+          return $ mkTyVarTy $ mkVanillaGlobal (mkSystemName (uniqFromSupply tUnique) (mkDataOcc "TypeNotFound")) (mkTyConTy starKindTyCon)
+
+        getFixities :: Ghc [(Module, (OccName, GHC.Fixity))]
+        getFixities = do env <- getSession
+                         pit <- liftIO $ eps_PIT <$> hscEPS env
+                         let hpt = hsc_HPT env
+                             ifaces = moduleEnvElts pit ++ map hm_iface (eltsUFM hpt)
+                         return $ concatMap (\mi -> map (mi_module mi, ) $ mi_fixities mi) ifaces
+
+extractExprIds :: LHsBinds Id -> [Located Id]
+        -- expressions like HsRecFld are removed from the typechecked representation, they are replaced by HsVar
+extractExprIds = catMaybes . map (\case L l (HsVar (L _ n)) -> Just (L l n)
+                                        L l (HsWrap _ (HsVar (L _ n))) -> Just (L l n)
+                                        _ -> Nothing
+                                 ) . 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
+  where getImplVars (EvBinds evbnds) = catMaybes $ map getEvVar $ bagToList evbnds
+        getEvVar (EvBind lhs _ False) = Just lhs
+        getEvVar _                    = Nothing
+
+extractSigBindIds :: LHsBinds Id -> [(SrcSpan,Id)]
+extractSigBindIds = catMaybes . map (\case L l bs@(IPBind (Right id) _) -> Just (l,id)
+                                           _                            -> Nothing
+                                    ) . concatMap universeBi . bagToList

+ Language/Haskell/Tools/AST/FromGHC/Binds.hs view

@@ -0,0 +1,142 @@+{-# 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.AST.FromGHC.Binds where
+
+import Control.Monad.Reader
+
+import SrcLoc as GHC
+import RdrName as GHC
+import HsBinds as GHC
+import HsExpr as GHC
+import BasicTypes as GHC
+import ApiAnnotation as GHC
+import Bag as GHC
+import Outputable as GHC
+import HsPat as GHC
+import HsDecls as GHC
+import HsTypes as GHC
+import OccName as GHC
+import Name as GHC
+import BooleanFormula as GHC
+
+import Data.List
+
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST.FromGHC.Exprs
+import Language.Haskell.Tools.AST.FromGHC.Patterns
+import Language.Haskell.Tools.AST.FromGHC.Types
+import Language.Haskell.Tools.AST.FromGHC.Kinds
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+
+import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), AnnListG(..), Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+
+trfBind :: TransformName n r => Located (HsBind n) -> Trf (Ann AST.UValueBind (Dom r) RangeStage)
+trfBind = trfLocNoSema trfBind'
+  
+trfBind' :: TransformName n r => HsBind n -> Trf (AST.UValueBind (Dom r) RangeStage)
+-- a value binding (not a function)
+trfBind' (FunBind { fun_id = id, fun_matches = MG { mg_alts = unLoc -> [L matchLoc (Match { m_pats = [], m_grhss = GRHSs [L rhsLoc (GRHS [] expr)] (unLoc -> locals) })]} }) 
+  = AST.USimpleBind <$> copyAnnot AST.UVarPat (define $ trfName id)
+                    <*> addToScope locals (annLocNoSema (combineSrcSpans (getLoc expr) <$> tokenLoc AnnEqual) (AST.UUnguardedRhs <$> trfExpr expr))
+                    <*> addToScope locals (trfWhereLocalBinds locals)
+trfBind' (FunBind id (MG (unLoc -> matches) _ _ _) _ _ _) = AST.UFunBind <$> makeNonemptyIndentedList (mapM (trfMatch (unLoc id)) matches)
+trfBind' (PatBind pat (GRHSs rhs (unLoc -> locals)) _ _ _) = AST.USimpleBind <$> trfPattern pat <*> trfRhss rhs <*> trfWhereLocalBinds locals
+trfBind' (AbsBinds _ _ _ _ _) = error "AbsBinds are not allowed as an input to the conversion (they are generated by the type checker)"
+trfBind' (PatSynBind _) = error "UPattern synonym bindings should be recognized on the declaration level"
+
+trfMatch :: TransformName n r => n -> Located (Match n (LHsExpr n)) -> Trf (Ann AST.UMatch (Dom r) RangeStage)
+trfMatch id = trfLocNoSema (trfMatch' id)
+
+trfMatch' :: TransformName n r => n -> Match n (LHsExpr n) -> Trf (AST.UMatch (Dom r) RangeStage)
+trfMatch' name (Match funid pats typ (GRHSs rhss (unLoc -> locBinds)))
+  -- TODO: add the optional typ to pats
+  = AST.UMatch <$> trfMatchLhs name funid pats
+               <*> addToScope pats (trfRhss rhss)
+               <*> addToScope pats (trfWhereLocalBinds locBinds)
+
+trfMatchLhs :: TransformName n r => n -> MatchFixity n -> [LPat n] -> Trf (Ann AST.UMatchLhs (Dom r) RangeStage)
+trfMatchLhs name fb pats 
+  = do implicitIdLoc <- mkSrcSpan <$> atTheStart <*> atTheStart
+       closeLoc <- srcSpanStart <$> (combineSrcSpans <$> tokenLoc AnnEqual <*> tokenLoc AnnVbar)
+       let (n, isInfix) = case fb of NonFunBindMatch -> (L implicitIdLoc name, False)
+                                     FunBindMatch n inf -> (n, inf)
+       args <- mapM trfPattern pats
+       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)
+            _                       -> AST.UNormalLhs <$> define (trfName n) <*> makeList " " (pure closeLoc) (pure args)
+
+trfRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.URhs (Dom r) RangeStage)
+-- the original location on the GRHS misleadingly contains the local bindings
+trfRhss [unLoc -> GRHS [] body] = annLocNoSema (combineSrcSpans (getLoc body) <$> tokenBefore (srcSpanStart $ getLoc body) AnnEqual) 
+                                         (AST.UUnguardedRhs <$> trfExpr body)
+trfRhss rhss = annLocNoSema (pure $ collectLocs rhss) 
+                      (AST.UGuardedRhss . nonemptyAnnList <$> mapM trfGuardedRhs rhss)
+                      
+trfGuardedRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.UGuardedRhs (Dom r) RangeStage)
+trfGuardedRhs = trfLocNoSema $ \(GRHS guards body) 
+  -> AST.UGuardedRhs . nonemptyAnnList <$> trfScopedSequence trfRhsGuard guards <*> addToScope guards (trfExpr body)
+  
+trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.URhsGuard (Dom r) RangeStage)
+trfRhsGuard = trfLocNoSema trfRhsGuard'
+  
+trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.URhsGuard (Dom r) RangeStage)
+trfRhsGuard' (BindStmt pat body _ _ _) = AST.UGuardBind <$> trfPattern pat <*> trfExpr body
+trfRhsGuard' (BodyStmt body _ _ _) = AST.UGuardCheck <$> trfExpr body
+trfRhsGuard' (LetStmt (unLoc -> binds)) = AST.UGuardLet <$> trfLocalBinds binds
+  
+trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybeG AST.ULocalBinds (Dom r) RangeStage)
+trfWhereLocalBinds EmptyLocalBinds = nothing "" "" atTheEnd
+trfWhereLocalBinds binds
+  = makeJust <$> annLocNoSema (combineSrcSpans (getBindLocs binds) <$> tokenLoc AnnWhere) (AST.ULocalBinds <$> addToScope binds (trfLocalBinds binds))
+
+getBindLocs :: HsLocalBinds n -> SrcSpan
+getBindLocs (HsValBinds (ValBindsIn binds sigs)) = foldLocs $ map getLoc (bagToList binds) ++ map getLoc sigs
+getBindLocs (HsValBinds (ValBindsOut binds sigs)) = foldLocs $ map getLoc (concatMap (bagToList . snd) binds) ++ map getLoc sigs
+getBindLocs (HsIPBinds (IPBinds binds _)) = foldLocs $ map getLoc binds
+  
+trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnListG AST.ULocalBind (Dom r) RangeStage)
+trfLocalBinds (HsValBinds (ValBindsIn binds sigs)) 
+  = makeIndentedList (after AnnWhere)
+      (orderDefs <$> ((++) <$> mapM (copyAnnot AST.ULocalValBind . trfBind) (bagToList binds) 
+                           <*> mapM trfLocalSig sigs))
+trfLocalBinds (HsValBinds (ValBindsOut binds sigs)) 
+  = makeIndentedList (after AnnWhere)
+      (orderDefs <$> ((++) <$> (concat <$> mapM (mapM (copyAnnot AST.ULocalValBind . trfBind) . bagToList . snd) binds)
+                           <*> mapM trfLocalSig sigs))
+trfLocalBinds (HsIPBinds (IPBinds binds _))
+  = makeIndentedList (after AnnWhere) (mapM trfIpBind binds)
+
+trfIpBind :: TransformName n r => Located (IPBind n) -> Trf (Ann AST.ULocalBind (Dom r) RangeStage)
+trfIpBind = trfLocNoSema $ \case
+  IPBind (Left (L l ipname)) expr -> AST.ULocalValBind <$> (annContNoSema $ AST.USimpleBind <$> focusOn l (annContNoSema (AST.UVarPat <$> define (trfImplicitName ipname)))
+                                                                                          <*> annFromNoSema AnnEqual (AST.UUnguardedRhs <$> trfExpr expr)
+                                                                                          <*> nothing " " "" atTheEnd)
+             
+trfLocalSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.ULocalBind (Dom r) RangeStage)
+trfLocalSig = trfLocNoSema $ \case
+  ts@(TypeSig {}) -> AST.ULocalSignature <$> annContNoSema (trfTypeSig' ts)
+  (FixSig fs) -> AST.ULocalFixity <$> annContNoSema (trfFixitySig fs)
+  
+trfTypeSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.UTypeSignature (Dom r) RangeStage)
+trfTypeSig = trfLocNoSema trfTypeSig'
+
+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)
+  
+trfFixitySig :: TransformName n r => FixitySig n -> Trf (AST.UFixitySignature (Dom r) RangeStage)
+trfFixitySig (FixitySig names (Fixity _ prec dir)) 
+  = AST.UFixitySignature <$> transformDir dir
+                         <*> annLocNoSema (tokenLoc AnnVal) (pure $ AST.Precedence prec) 
+                         <*> (nonemptyAnnList . nub <$> 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)
+        
+        directionChar = annLocNoSema ((\l -> mkSrcSpan (updateCol (subtract 1) l) l) . srcSpanEnd <$> tokenLoc AnnInfix)

+ Language/Haskell/Tools/AST/FromGHC/Binds.hs-boot view

@@ -0,0 +1,17 @@+module Language.Haskell.Tools.AST.FromGHC.Binds where
+
+import Outputable as GHC
+import RdrName as GHC
+import SrcLoc as GHC
+import HsBinds as GHC
+import HsExpr as GHC
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), AnnListG(..), Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+
+trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnListG AST.ULocalBind (Dom r) RangeStage)
+trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybeG AST.ULocalBinds (Dom r) RangeStage)
+trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.URhsGuard (Dom r) RangeStage)
+trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.URhsGuard (Dom r) RangeStage)

+ Language/Haskell/Tools/AST/FromGHC/Decls.hs view

@@ -0,0 +1,516 @@+{-# LANGUAGE LambdaCase 
+           , ViewPatterns
+           , ScopedTypeVariables
+           #-}
+-- | Functions that convert the declarations of the GHC AST to corresponding elements in the Haskell-tools AST representation
+module Language.Haskell.Tools.AST.FromGHC.Decls where
+
+import qualified GHC
+import RdrName as GHC
+import Var as GHC
+import Class as GHC
+import HsSyn as GHC
+import SrcLoc as GHC
+import HsDecls as GHC
+import Name as GHC
+import OccName as GHC
+import ApiAnnotation as GHC
+import FastString as GHC
+import BasicTypes as GHC
+import Bag as GHC
+import ForeignCall as GHC
+import Outputable as GHC
+import Unique as GHC
+import TyCon as GHC
+import BooleanFormula as GHC
+
+import Control.Monad.Reader
+import Control.Reference
+import Data.Function (on)
+import Data.List
+import Data.Maybe
+import qualified Data.Map as Map
+import Data.Data (toConstr)
+import Data.Generics.Uniplate.Data
+
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST.FromGHC.Kinds
+import Language.Haskell.Tools.AST.FromGHC.Types
+import Language.Haskell.Tools.AST.FromGHC.Exprs
+import Language.Haskell.Tools.AST.FromGHC.Patterns
+import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH
+import Language.Haskell.Tools.AST.FromGHC.Binds
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+
+import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), AnnListG(..), getRange, Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+import Language.Haskell.Tools.AST.SemaInfoTypes as AST
+
+import Data.Dynamic
+import Debug.Trace
+
+trfDecls :: TransformName n r => [LHsDecl n] -> Trf (AnnListG AST.UDecl (Dom r) RangeStage)
+-- TODO: filter documentation comments
+trfDecls decls = addToCurrentScope decls $ makeIndentedListNewlineBefore atTheEnd (mapM trfDecl decls)
+
+trfDeclsGroup :: forall n r . TransformName n r => HsGroup n -> Trf (AnnListG AST.UDecl (Dom r) RangeStage)
+trfDeclsGroup (HsGroup vals splices tycls insts derivs fixities defaults foreigns warns anns rules vects docs) 
+  = do spls <- getDeclSplices
+       let (sigs, bagToList -> binds) = getBindsAndSigs vals
+           alldecls :: [Located (HsDecl n)]
+           alldecls = (map (fmap SpliceD) splices)
+                        ++ (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)
+                        ++ (map (fmap ForD) foreigns)
+                        ++ (map (fmap WarningD) warns)
+                        ++ (map (fmap AnnD) anns)
+                        ++ (map (fmap RuleD) rules)
+                        ++ (map (fmap VectD) vects)
+       let actualDefinitions = replaceSpliceDecls spls alldecls
+       addToCurrentScope actualDefinitions $ makeIndentedListNewlineBefore atTheEnd (orderDefs <$> ((++) <$> getDeclsToInsert <*> (mapM trfDecl actualDefinitions)))
+  where 
+    replaceSpliceDecls :: [Located (HsSplice n)] -> [Located (HsDecl n)] -> [Located (HsDecl n)]
+    replaceSpliceDecls splices decls = foldl mergeSplice decls splices
+    
+    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
+    
+    getDeclsToInsert :: Trf [Ann AST.UDecl (Dom r) RangeStage]
+    getDeclsToInsert = do decls <- asks declsToInsert
+                          locals <- asks (head . localsInScope)
+                          liftGhc $ mapM (loadIdsForDecls locals) decls
+       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)) 
+                                                       $ 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 _)) 
+    -> AST.UClosedTypeFamilyDecl <$> focusAfter AnnType (createDeclHead name tyVars) 
+                                <*> trfFamilyKind kindSig 
+                                <*> trfTypeEqs typeEqs
+  TyClD (FamDecl fd) -> AST.UTypeFamilyDecl <$> annContNoSema (trfTypeFam' fd)
+  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) _ _) 
+    -> 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 docs _) 
+    -> AST.UClassDecl <$> trfCtx (after AnnClass) ctx 
+                     <*> betweenIfPresent AnnClass AnnWhere (createDeclHead name vars)
+                     <*> trfFunDeps funDeps 
+                     <*> createClassBody sigs defs typeFuns typeFunDefs
+  InstD (ClsInstD (ClsInstDecl typ binds sigs typefam datafam overlap))
+    -> 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) _))
+    -> AST.UDataInstDecl <$> trfDataKeyword nd
+                        <*> between AnnInstance AnnEqual (makeInstanceRuleTyVars con pats)
+                        <*> makeList " | " (after AnnEqual) (mapM trfConDecl cons)
+                        <*> trfMaybe "" "" trfDerivings derivs
+  InstD (TyFamInstD (TyFamInstDecl (L 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)
+  -- TODO: INLINE, SPECIALIZE, MINIMAL, VECTORISE pragmas, Warnings, Annotations, rewrite rules, role annotations
+  RuleD (HsRules _ rules) -> AST.UPragmaDecl <$> annContNoSema (AST.URulePragma <$> makeIndentedList (before AnnClose) (mapM trfRewriteRule rules))
+  RoleAnnotD (RoleAnnotDecl name roles) -> AST.URoleDecl <$> trfQualifiedName name <*> makeList " " atTheEnd (mapM trfRole roles)
+  DefD (DefaultDecl types) -> AST.UDefaultDecl . nonemptyAnnList <$> mapM trfType types
+  ForD (ForeignImport name (hsib_body -> typ) _ (CImport ccall safe _ _ _)) 
+    -> AST.UForeignImport <$> trfCallConv ccall <*> trfSafety (getLoc ccall) safe <*> define (trfName name) <*> trfType typ
+  ForD (ForeignExport name (hsib_body -> typ) _ (CExport (L l (CExportStatic _ _ ccall)) _)) 
+    -> AST.UForeignExport <$> annLocNoSema (pure l) (trfCallConv' ccall) <*> trfName name <*> trfType typ
+  SpliceD (SpliceDecl (unLoc -> spl) _) -> AST.USpliceDecl <$> (annContNoSema $ trfSplice' spl)
+  AnnD (HsAnnotation stxt subject expr) 
+    -> AST.UPragmaDecl <$> annContNoSema (AST.UAnnPragma <$> trfAnnotationSubject stxt subject (srcSpanStart $ getLoc expr) <*> trfExpr expr)
+  d -> error ("Illegal declaration: " ++ showSDocUnsafe (ppr d) ++ " (ctor: " ++ show (toConstr d) ++ ")")
+
+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)
+trfGADT nd name vars ctx kind cons derivs ctxTok consLoc
+  = AST.UGDataDecl <$> trfDataKeyword nd
+                   <*> trfCtx (after ctxTok) ctx
+                   <*> betweenIfPresent ctxTok AnnEqual (createDeclHead name vars)
+                   <*> trfKindSig kind
+                   <*> makeIndentedListBefore " where " consLoc (mapM trfGADTConDecl cons)
+                   <*> trfMaybe "" "" trfDerivings derivs
+
+trfDataDef :: TransformName n r => NewOrData -> Located n -> LHsQTyVars n -> Located (HsContext n) 
+                                     -> [Located (ConDecl n)] -> Maybe (Located [LHsSigType 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
+
+trfVal :: TransformName n r => HsBindLR n n -> Trf (AST.UDecl (Dom r) RangeStage)
+trfVal (PatSynBind psb) = AST.UPatternSynonymDecl <$> annContNoSema (trfPatternSynonym psb)
+trfVal bind = AST.UValueBinding <$> (annContNoSema $ trfBind' bind)
+
+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 (InlineSig name (InlinePragma _ Inlinable _ phase _)) 
+  = AST.UPragmaDecl <$> annContNoSema (AST.UInlinablePragma <$> trfPhase (pure $ srcSpanStart $ getLoc name) phase <*> trfName name)
+trfSig (InlineSig name (InlinePragma src inl _ phase cl)) 
+  = do rng <- asks contRange
+       let parts = map getLoc $ splitLocated (L rng src)
+       AST.UPragmaDecl <$> annContNoSema ((case inl of Inline -> AST.UInlinePragma; NoInline -> AST.UNoInlinePragma) 
+                                     <$> trfConlike parts cl 
+                                     <*> trfPhase (pure $ srcSpanStart (getLoc name)) phase 
+                                     <*> trfName name)
+trfSig (SpecSig name (map hsib_body -> types) (inl_act -> phase)) 
+  = AST.UPragmaDecl <$> annContNoSema (AST.USpecializePragma <$> trfPhase (pure $ srcSpanStart (getLoc name)) phase 
+                                       <*> trfName name 
+                                       <*> (orderAnnList <$> trfAnnList ", " trfType' types))
+trfSig s = error ("Illegal signature: " ++ showSDocUnsafe (ppr s) ++ " (ctor: " ++ show (toConstr s) ++ ")")
+
+trfConlike :: [SrcSpan] -> RuleMatchInfo -> Trf (AnnMaybeG AST.UConlikeAnnot (Dom r) RangeStage)
+trfConlike parts ConLike = makeJust <$> annLocNoSema (pure $ parts !! 2) (pure AST.UConlikeAnnot)
+trfConlike parts FunLike = nothing " " "" (pure $ srcSpanEnd $ parts !! 1)
+
+trfConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.UConDecl (Dom r) RangeStage)
+trfConDecl = trfLocNoSema trfConDecl'
+
+trfConDecl' :: TransformName n r => ConDecl n -> Trf (AST.UConDecl (Dom r) RangeStage)
+trfConDecl' (ConDeclH98 { con_name = name, con_details = PrefixCon args })
+  = AST.UConDecl <$> define (trfName name) <*> makeList " " atTheEnd (mapM trfType args)
+trfConDecl' (ConDeclH98 { con_name = name, con_details = RecCon (unLoc -> flds) })
+  = AST.URecordDecl <$> define (trfName name) <*> (between AnnOpenC AnnCloseC $ trfAnnList ", " trfFieldDecl' flds)
+trfConDecl' (ConDeclH98 { con_name = name, con_details = InfixCon t1 t2 })
+  = AST.UInfixConDecl <$> trfType t1 <*> define (trfOperator name) <*> trfType t2
+
+trfGADTConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.UGadtConDecl (Dom r) RangeStage)
+trfGADTConDecl = trfLocNoSema $ \(ConDeclGADT { con_names = names, con_type = hsib_body -> typ })
+  -> AST.UGadtConDecl <$> define (trfAnnList ", " trfName' names) 
+                     <*> trfGadtConType typ
+
+trfGadtConType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UGadtConType (Dom r) RangeStage)
+trfGadtConType = trfLocNoSema $ \case 
+  HsFunTy (cleanHsType . unLoc -> HsRecTy flds) resType 
+    -> AST.UGadtRecordType <$> between AnnOpenC AnnCloseC (trfAnnList ", " trfFieldDecl' flds) 
+                          <*> trfType resType
+  typ -> AST.UGadtNormalType <$> annContNoSema (trfType' typ)
+
+trfFieldDecl :: TransformName n r => Located (ConDeclField n) -> Trf (Ann AST.UFieldDecl (Dom r) RangeStage)
+trfFieldDecl = trfLocNoSema trfFieldDecl'
+
+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 = trfLocNoSema $ \case
+  [hsib_body -> typ@(unLoc -> HsTyVar cls)] -> AST.UDerivingOne <$> trfInstanceHead typ
+  derivs -> AST.UDerivings <$> trfAnnList ", " trfInstanceHead' (map hsib_body derivs)
+  
+trfInstanceRule :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage)
+trfInstanceRule = trfLocNoSema (trfInstanceRule' . cleanHsType)
+
+trfInstanceRule' :: TransformName n r => HsType n -> Trf (AST.UInstanceRule (Dom r) RangeStage)
+trfInstanceRule' (HsForAllTy bndrs (unLoc -> HsQualTy ctx typ))
+  = AST.UInstanceRule <$> (makeJust <$> annLocNoSema (pure $ collectLocs bndrs) (trfBindings bndrs)) 
+                      <*> trfCtx (after AnnDot) ctx
+                      <*> trfInstanceHead typ
+trfInstanceRule' (HsQualTy ctx typ) = AST.UInstanceRule <$> nothing "" " . " atTheStart 
+                                                        <*> trfCtx atTheStart ctx
+                                                        <*> trfInstanceHead typ
+trfInstanceRule' (HsParTy typ) = instanceHead $ annContNoSema (AST.UInstanceHeadParen <$> trfInstanceHead typ)
+trfInstanceRule' (HsTyVar tv) = instanceHead $ annContNoSema (AST.UInstanceHeadCon <$> trfName tv)
+trfInstanceRule' (HsAppTy t1 t2) = instanceHead $ annContNoSema (AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2)
+trfInstanceRule' t = error (showSDocUnsafe $ ppr t)
+
+instanceHead :: Trf (Ann AST.UInstanceHead (Dom r) RangeStage) -> Trf (AST.UInstanceRule (Dom r) RangeStage)
+instanceHead hd = AST.UInstanceRule <$> (nothing "" " . " atTheStart) <*> (nothing " " "" atTheStart) <*> hd
+                            
+makeInstanceRuleTyVars :: TransformName n r => Located n -> HsImplicitBndrs n [LHsType n] -> Trf (Ann AST.UInstanceRule (Dom r) RangeStage)
+makeInstanceRuleTyVars n vars = annContNoSema
+  $ AST.UInstanceRule <$> nothing "" " . " atTheStart
+                      <*> nothing " " "" atTheStart
+                      <*> foldl (\c t -> annLocNoSema (pure $ combineSrcSpans (getLoc n) (getLoc t)) $ AST.UInstanceHeadApp <$> c <*> (trfType t))
+                                (copyAnnot AST.UInstanceHeadCon (trfName n))
+                                (hsib_body vars)
+
+trfInstanceHead :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UInstanceHead (Dom r) RangeStage)
+trfInstanceHead = trfLocNoSema trfInstanceHead'
+
+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'' (HsAppTy t1 t2) = AST.UInstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2
+  trfInstanceHead'' (HsParTy typ) = AST.UInstanceHeadParen <$> trfInstanceHead typ
+  trfInstanceHead'' (HsOpTy t1 op t2) 
+    = AST.UInstanceHeadApp <$> (annLocNoSema (pure $ combineSrcSpans (getLoc t1) (getLoc op))
+                                             (AST.UInstanceHeadInfix <$> trfType t1 <*> trfName op)) 
+                          <*> trfType t2
+  trfInstanceHead'' t = error ("Illegal instance head: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")")
+ 
+trfTypeEqs :: TransformName n r => Maybe [Located (TyFamInstEqn n)] -> Trf (AnnListG AST.UTypeEqn (Dom r) RangeStage)
+trfTypeEqs Nothing = makeList "\n" (after AnnWhere) (pure [])
+trfTypeEqs (Just eqs) = makeNonemptyList "\n" (mapM trfTypeEq eqs)
+
+trfTypeEq :: TransformName n r => Located (TyFamInstEqn n) -> Trf (Ann AST.UTypeEqn (Dom r) RangeStage)
+trfTypeEq = trfLocNoSema $ \(TyFamEqn name pats rhs) 
+  -> AST.UTypeEqn <$> defineTypeVars (focusBefore AnnEqual (combineTypes name (hsib_body pats))) <*> trfType rhs
+  where combineTypes :: TransformName n r => Located n -> [LHsType n] -> Trf (Ann AST.UType (Dom r) RangeStage)
+        combineTypes name (lhs : rhs : rest) | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs)
+          = annContNoSema $ AST.UTyInfix <$> trfType lhs <*> trfOperator name <*> trfType rhs
+        combineTypes name pats = wrapTypes (annLocNoSema (pure $ getLoc name) (AST.UTyVar <$> trfName name)) pats
+
+        wrapTypes :: TransformName n r => Trf (Ann AST.UType (Dom r) RangeStage) -> [LHsType n] -> Trf (Ann AST.UType (Dom r) RangeStage)
+        wrapTypes base pats 
+          = foldl (\t p -> do typ <- t
+                              annLocNoSema (pure $ combineSrcSpans (getRange typ) (getLoc p)) 
+                                     (AST.UTyApp <$> pure typ <*> trfType p)) base pats
+                 
+trfFunDeps :: TransformName n r => [Located (FunDep (Located n))] -> Trf (AnnMaybeG AST.UFunDeps (Dom r) RangeStage)
+trfFunDeps [] = nothing "| " "" $ focusBeforeIfPresent AnnWhere atTheEnd
+trfFunDeps fundeps = makeJust <$> annLocNoSema (combineSrcSpans (collectLocs fundeps) <$> tokenLoc AnnVbar) 
+                                         (AST.UFunDeps <$> trfAnnList ", " trfFunDep' fundeps)
+  
+trfFunDep' :: TransformName n r => FunDep (Located n) -> Trf (AST.UFunDep (Dom r) RangeStage)
+trfFunDep' (lhs, rhs) = AST.UFunDep <$> trfAnnList ", " trfName' lhs <*> trfAnnList ", " trfName' rhs
+
+createDeclHead :: TransformName n r => Located n -> LHsQTyVars n -> Trf (Ann AST.UDeclHead (Dom r) RangeStage)
+createDeclHead name (hsq_explicit -> lhs : rhs : rest)
+  | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs)
+  -- infix declaration
+  = wrapDeclHead rest
+      $ annLocNoSema (addParenLocs $ getLoc lhs `combineSrcSpans` getLoc rhs) 
+                     (AST.UDHInfix <$> defineTypeVars (trfTyVar lhs) <*> define (trfOperator name) <*> defineTypeVars (trfTyVar rhs))
+createDeclHead name vars = defineTypeVars $ wrapDeclHead (hsq_explicit vars) (define $ copyAnnot AST.UDeclHead (trfName name))
+
+wrapDeclHead :: TransformName n r => [LHsTyVarBndr n] -> Trf (Ann AST.UDeclHead (Dom r) RangeStage) -> Trf (Ann AST.UDeclHead (Dom r) RangeStage)
+wrapDeclHead vars base
+  = foldl (\t p -> do typ <- t 
+                      annLocNoSema (addParenLocs $ combineSrcSpans (getRange typ) (getLoc p)) 
+                             (AST.UDHApp typ <$> trfTyVar p)
+          ) base vars
+
+-- | Get the parentheses directly before and after (for parenthesized application)
+addParenLocs :: SrcSpan -> Trf SrcSpan
+addParenLocs sp 
+  = let possibleSpan = mkSrcSpan (updateCol (subtract 1) (srcSpanStart sp)) (updateCol (+1) (srcSpanEnd sp))
+     in local (\s -> s { contRange = possibleSpan })
+              (combineSrcSpans <$> (combineSrcSpans sp <$> tokenLoc AnnOpenP) <*> tokenLocBack AnnCloseP)
+      
+         
+createClassBody :: TransformName n r => [LSig n] -> LHsBinds n -> [LFamilyDecl n] 
+                               -> [LTyFamDefltEqn n] -> Trf (AnnMaybeG AST.UClassBody (Dom r) RangeStage)
+createClassBody sigs binds typeFams typeFamDefs 
+  = do isThereWhere <- isGoodSrcSpan <$> (tokenLoc AnnWhere)
+       if isThereWhere 
+         then makeJust <$> annLocNoSema (combinedLoc <$> tokenLoc AnnWhere) 
+                                        (AST.UClassBody <$> makeList "" (after AnnWhere) 
+                                                                       (orderDefs . concat <$> sequenceA allDefs))
+         else nothing " where " "" atTheEnd
+  where combinedLoc wh = foldl combineSrcSpans wh allLocs
+        allLocs = map getLoc sigs ++ map getLoc (bagToList binds) ++ map getLoc typeFams ++ map getLoc typeFamDefs
+        allDefs = [getSigs, getBinds, getFams, getFamDefs]
+        getSigs = mapM trfClassElemSig sigs
+        getBinds = mapM (copyAnnot AST.UClsDef . trfBind) (bagToList binds)
+        getFams = mapM (copyAnnot AST.UClsTypeFam . trfTypeFam) typeFams
+        getFamDefs = mapM trfTypeFamDef typeFamDefs
+       
+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))
+  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))
+  MinimalSig _ formula -> AST.UClsMinimal <$> trfMinimalFormula formula
+  s -> error ("Illegal signature: " ++ showSDocUnsafe (ppr s) ++ " (ctor: " ++ show (toConstr s) ++ ")")
+         
+trfTypeFam :: TransformName n r => Located (FamilyDecl n) -> Trf (Ann AST.UTypeFamily (Dom r) RangeStage)
+trfTypeFam = trfLocNoSema trfTypeFam'
+
+trfTypeFam' :: TransformName n r => FamilyDecl n -> Trf (AST.UTypeFamily (Dom r) RangeStage)
+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)
+  = AST.UTypeFamily <$> (case unLoc kindSig of KindSig _ -> between AnnType AnnDcolon; _ -> id) (createDeclHead name tyVars) 
+                   <*> trfFamilyResultSig kindSig injectivity
+
+trfTypeFamDef :: TransformName n r => Located (TyFamDefltEqn n) -> Trf (Ann AST.UClassElement (Dom r) RangeStage)
+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)
+trfInstBody binds sigs fams dats = do
+    wh <- tokenLoc AnnWhere
+    if isGoodSrcSpan wh then
+      makeJust <$> annLocNoSema (combinedLoc <$> tokenLoc AnnWhere) 
+                          (AST.UInstBody <$> (makeList "" (after AnnWhere) 
+                                                         (orderDefs . concat <$> sequenceA allDefs)))
+    else nothing " where " "" atTheEnd
+  where combinedLoc wh = foldl combineSrcSpans wh allLocs
+        allLocs = map getLoc sigs ++ map getLoc (bagToList binds) ++ map getLoc fams ++ map getLoc dats
+        allDefs = [getSigs, getBinds, getFams, getDats]
+        getSigs = mapM trfClassInstSig sigs
+        getBinds = mapM (copyAnnot AST.UInstBodyNormalDecl . trfBind) (bagToList binds)
+        getFams = mapM trfInstTypeFam fams
+        getDats = mapM trfInstDataFam dats
+          
+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))
+  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)
+  s -> error ("Illegal class instance signature: " ++ showSDocUnsafe (ppr s) ++ " (ctor: " ++ show (toConstr s) ++ ")")
+          
+trfInstTypeFam :: TransformName n r => Located (TyFamInstDecl n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage)
+trfInstTypeFam (unLoc -> TyFamInstDecl eqn _) = copyAnnot AST.UInstBodyTypeDecl (trfTypeEq eqn)
+
+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 _ _ cons derivs) _) 
+    -> AST.UInstBodyDataDecl 
+         <$> trfDataKeyword dn 
+         <*> annLocNoSema (pure $ collectLocs pats `combineSrcSpans` getLoc tc `combineSrcSpans` getLoc ctx)
+                          (AST.UInstanceRule <$> nothing "" " . " atTheStart
+                                             <*> trfCtx atTheStart ctx 
+                                             <*> foldr (\t r -> annLocNoSema (combineSrcSpans (getLoc t) . getRange <$> r) 
+                                                                             (AST.UInstanceHeadApp <$> r <*> (trfType t))) 
+                                                       (copyAnnot AST.UInstanceHeadCon (trfName tc)) pats)
+         <*> trfAnnList "" trfConDecl' cons
+         <*> trfMaybe " deriving " "" trfDerivings derivs
+          
+trfPatternSynonym :: forall n r . TransformName n r => PatSynBind n n -> Trf (AST.UPatternSynonym (Dom r) RangeStage)
+trfPatternSynonym (PSB id _ lhs def dir)
+  = let sep = case dir of ImplicitBidirectional -> AnnEqual
+                          _                     -> AnnLarrow
+        rhsLoc = combineSrcSpans (getLoc def) <$> tokenLoc sep
+        -- we use the selector name instead of the pattern variable name
+        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
+                            <*> annLocNoSema rhsLoc (trfPatSynRhs dir changedRhs)
+
+  where trfPatSynLhs :: TransformName n r => Located n -> HsPatSynDetails (Located n) -> Trf (Ann AST.UPatSynLhs (Dom r) RangeStage)
+        trfPatSynLhs id (PrefixPatSyn args)
+          = annLocNoSema (pure $ foldLocs (getLoc id : map getLoc args)) $ AST.UNormalPatSyn <$> trfName id <*> trfAnnList " " trfName' args
+        trfPatSynLhs op (InfixPatSyn lhs rhs)
+          = annLocNoSema (pure $ getLoc lhs `combineSrcSpans` getLoc rhs) $ AST.UInfixPatSyn <$> trfName lhs <*> trfOperator op <*> trfName rhs
+        trfPatSynLhs id (RecordPatSyn flds)
+          = annLocNoSema (mkSrcSpan (srcSpanStart (getLoc id)) <$> before AnnEqual) 
+              $ AST.URecordPatSyn <$> trfName id <*> trfAnnList ", " trfName' (map recordPatSynSelectorId flds)
+
+        trfPatSynRhs :: TransformName n r => HsPatSynDir n -> Located (Pat n) -> Trf (AST.UPatSynRhs (Dom r) RangeStage)
+        trfPatSynRhs ImplicitBidirectional pat = AST.UBidirectionalPatSyn <$> trfPattern pat <*> nothing " where " "" atTheEnd
+        trfPatSynRhs (ExplicitBidirectional mg) pat = AST.UBidirectionalPatSyn <$> trfPattern pat <*> (makeJust <$> trfPatSynWhere mg)
+        trfPatSynRhs Unidirectional pat = AST.UOneDirectionalPatSyn <$> trfPattern pat
+        trfPatSynWhere :: TransformName n r => MatchGroup n (LHsExpr n) -> Trf (Ann AST.UPatSynWhere (Dom r) RangeStage)
+        trfPatSynWhere (MG { mg_alts = alts }) = annLocNoSema (pure $ getLoc alts) (AST.UPatSynWhere <$> makeIndentedList (after AnnWhere) (mapM (trfMatch (unLoc id)) (unLoc alts)))
+
+trfFamilyKind :: TransformName n r => Located (FamilyResultSig n) -> Trf (AnnMaybeG AST.UKindConstraint (Dom r) RangeStage)
+trfFamilyKind (unLoc -> fr) = case fr of
+  NoSig -> nothing "" " " atTheEnd
+  KindSig k -> trfKindSig (Just k)
+
+trfFamilyResultSig :: TransformName n r => Located (FamilyResultSig n) -> Maybe (LInjectivityAnn n) -> Trf (AnnMaybeG AST.UTypeFamilySpec (Dom r) RangeStage)
+trfFamilyResultSig (L l fr) Nothing = case fr of 
+  NoSig -> nothing "" " " atTheEnd
+  KindSig k -> makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyKind <$> trfKindSig' k)
+trfFamilyResultSig _ (Just (L l (InjectivityAnn n deps))) 
+  = makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyInjectivity <$> (annContNoSema $ AST.UInjectivityAnn <$> trfName n <*> trfAnnList ", " trfName' deps))
+
+trfAnnotationSubject :: TransformName n r => SourceText -> AnnProvenance n -> SrcLoc -> Trf (Ann AST.UAnnotationSubject (Dom r) RangeStage)
+trfAnnotationSubject 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)) 
+                                                                      (AST.UTypeAnnotation <$> trfName name)
+                       ModuleAnnProvenance -> annLocNoSema (pure $ mkSrcSpan payloadStart payloadEnd) (pure AST.UModuleAnnotation)
+  
+trfDataKeyword ::  NewOrData -> Trf (Ann AST.UDataOrNewtypeKeyword (Dom r) RangeStage)
+trfDataKeyword NewType = annLocNoSema (tokenLoc AnnNewtype) (pure AST.UNewtypeKeyword)
+trfDataKeyword DataType = annLocNoSema (tokenLoc AnnData) (pure AST.UDataKeyword)
+     
+trfCallConv :: Located CCallConv -> Trf (Ann AST.UCallConv (Dom r) RangeStage)
+trfCallConv = trfLocNoSema trfCallConv'
+   
+trfCallConv' :: CCallConv -> Trf (AST.UCallConv (Dom r) RangeStage)
+trfCallConv' CCallConv = pure AST.UCCall
+trfCallConv' CApiConv = pure AST.UCApi
+trfCallConv' StdCallConv = pure AST.UStdCall
+-- trfCallConv' PrimCallConv = 
+trfCallConv' JavaScriptCallConv = pure AST.UJavaScript
+
+trfSafety :: SrcSpan -> Located Safety -> Trf (AnnMaybeG AST.USafety (Dom r) RangeStage)
+trfSafety ccLoc lsaf@(L l _) | isGoodSrcSpan l 
+  = makeJust <$> trfLocNoSema (pure . \case
+      PlaySafe -> AST.USafe
+      PlayInterruptible -> AST.UInterruptible
+      PlayRisky -> AST.UUnsafe) lsaf
+  | otherwise = nothing " " "" (pure $ srcSpanEnd ccLoc)
+
+trfOverlap :: Located OverlapMode -> Trf (Ann AST.UOverlapPragma (Dom r) RangeStage)
+trfOverlap = trfLocNoSema $ pure . \case
+  NoOverlap _ -> AST.UDisableOverlap
+  Overlappable _ -> AST.UOverlappable
+  Overlapping _ -> AST.UOverlapping
+  Overlaps _ -> AST.UOverlaps
+  Incoherent _ -> AST.UIncoherentOverlap
+
+trfRole :: Located (Maybe Role) -> Trf (Ann AST.URole (Dom r) RangeStage)
+trfRole = trfLocNoSema $ \case Just Nominal -> pure AST.UNominal
+                               Just Representational -> pure AST.URepresentational
+                               Just GHC.Phantom -> pure AST.UPhantom
+         
+trfPhase :: Trf SrcLoc -> Activation -> Trf (AnnMaybeG AST.UPhaseControl (Dom r) RangeStage)
+trfPhase l AlwaysActive = nothing "" " " l
+trfPhase _ (ActiveAfter _ pn) = makeJust <$> annLocNoSema (combineSrcSpans <$> tokenLoc AnnOpenS <*> tokenLoc AnnCloseS) 
+                                                          (AST.UPhaseControl <$> nothing "" "" (before AnnCloseS) <*> trfPhaseNum pn)
+trfPhase _ (ActiveBefore _ pn) = makeJust <$> annLocNoSema (combineSrcSpans <$> tokenLoc AnnOpenS <*> tokenLoc AnnCloseS)
+                                                           (AST.UPhaseControl <$> (makeJust <$> annLocNoSema (tokenLoc AnnTilde) (pure AST.PhaseInvert)) <*> trfPhaseNum pn)
+
+trfPhaseNum ::  PhaseNum -> Trf (Ann AST.PhaseNumber (Dom r) RangeStage)
+trfPhaseNum i = annLocNoSema (tokenLoc AnnVal) $ pure (AST.PhaseNumber $ fromIntegral i) 
+   
+trfRewriteRule :: TransformName n r => Located (RuleDecl n) -> Trf (Ann AST.URule (Dom r) RangeStage)
+trfRewriteRule = trfLocNoSema $ \(HsRule (L nameLoc (_, ruleName)) act bndrs left _ right _) ->
+  AST.URule <$> trfFastString (L nameLoc ruleName) 
+            <*> trfPhase (before AnnForall) act
+            <*> makeNonemptyList " " (mapM trfRuleBndr bndrs)
+            <*> trfExpr left
+            <*> trfExpr right
+
+trfRuleBndr :: TransformName n r =>  Located (RuleBndr n) -> Trf (Ann AST.UTyVar (Dom r) RangeStage)
+trfRuleBndr = trfLocNoSema $ \case (RuleBndr n) -> AST.UTyVarDecl <$> trfName n <*> nothing " " "" atTheEnd
+                                   (RuleBndrSig n k) -> AST.UTyVarDecl <$> trfName n <*> (makeJust <$> (trfKindSig' (hswc_body $ hsib_body k)))
+
+trfMinimalFormula :: TransformName n r => Located (BooleanFormula (Located n)) -> Trf (Ann AST.UMinimalFormula (Dom r) RangeStage)
+trfMinimalFormula = trfLocNoSema 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' (Or formulas) = AST.UMinimalOr <$> trfAnnList " | " trfMinimalFormula' formulas
+trfMinimalFormula' (Parens formula) = AST.UMinimalParen <$> trfMinimalFormula formula

+ Language/Haskell/Tools/AST/FromGHC/Exprs.hs view

@@ -0,0 +1,229 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , ScopedTypeVariables
+           , TypeApplications
+           , AllowAmbiguousTypes
+           #-}
+-- | Functions that convert the expression-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation
+module Language.Haskell.Tools.AST.FromGHC.Exprs where
+
+import Data.Maybe
+import Data.List (partition, find)
+import Data.Data (toConstr)
+import Control.Monad.Reader
+import Control.Reference
+
+import GHC
+import SrcLoc as GHC
+import RdrName as GHC
+import HsTypes as GHC
+import HsPat as GHC
+import HsExpr as GHC
+import HsBinds as GHC
+import HsLit as GHC
+import BasicTypes as GHC
+import ApiAnnotation as GHC
+import FastString as GHC
+import Outputable as GHC
+import PrelNames as GHC
+import DataCon as GHC
+
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST.FromGHC.Types
+import Language.Haskell.Tools.AST.FromGHC.Literals
+import Language.Haskell.Tools.AST.FromGHC.Patterns
+import Language.Haskell.Tools.AST.FromGHC.Stmts
+import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Binds
+import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+import Language.Haskell.Tools.AST.SemaInfoTypes
+
+import Language.Haskell.Tools.AST (Ann(..), AnnListG(..), Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+
+import Debug.Trace
+
+trfExpr :: forall n r . TransformName n r => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage)
+-- correction for empty cases
+trfExpr (L l cs@(HsCase expr (unLoc . mg_alts -> []))) 
+  = do let realSpan = combineSrcSpans l (getLoc expr)
+       tokensAfter <- allTokensAfter (srcSpanEnd realSpan)
+       let actualSpan = case take 3 tokensAfter of 
+                          [(_, AnnOf), (_, AnnOpenC), (endSpan, AnnCloseC)] -> realSpan `combineSrcSpans` endSpan
+                          ((endSpan, AnnOf) : _) -> realSpan `combineSrcSpans` endSpan
+       annLoc createScopeInfo (pure actualSpan) (trfExpr' cs)
+trfExpr e = do exprSpls <- asks exprSplices
+               let RealSrcSpan loce = getLoc e
+                   contSplice = find (\sp -> case getSpliceLoc sp of (RealSrcSpan spLoc) -> spLoc `containsSpan` loce; _ -> False) exprSpls
+               case contSplice of Just sp -> case sp of HsQuasiQuote {} -> exprSpliceInserted sp (annCont createScopeInfo (AST.UQuasiQuoteExpr <$> annLocNoSema (pure $ getSpliceLoc sp) (trfQuasiQuotation' sp)))
+                                                        _               -> exprSpliceInserted sp (annCont createScopeInfo (AST.USplice <$> annLocNoSema (pure $ getSpliceLoc sp) (trfSplice' sp)))
+                                  Nothing -> trfLoc trfExpr' createScopeInfo e
+
+createScopeInfo :: Trf ScopeInfo
+createScopeInfo = do scope <- asks localsInScope
+                     return (mkScopeInfo scope)
+
+trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.UExpr (Dom r) RangeStage)
+trfExpr' (HsVar name) = AST.UVar <$> trfName 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' (HsLam (unLoc . mg_alts -> [unLoc -> Match _ pats _ (GRHSs [unLoc -> GRHS [] expr] (unLoc -> EmptyLocalBinds))]))
+  = AST.ULambda <$> (trfAnnList " " trfPattern' pats) <*> addToScope pats (trfExpr expr)
+trfExpr' (HsLamCase _ (unLoc . mg_alts -> matches)) = AST.ULamCase <$> 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
+trfExpr' (NegApp e _) = AST.UPrefixApp <$> annLocNoSema loc (AST.UNormalOp <$> annLoc info loc (AST.nameFromList <$> trfNameStr "-"))
+                                       <*> trfExpr e
+  where loc = mkSrcSpan <$> atTheStart <*> (pure $ srcSpanStart (getLoc e))
+        info = createNameInfo =<< (fromMaybe (error "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 -> SectionR (unLoc -> HsVar op) expr)) = AST.URightSection <$> trfOperator op <*> trfExpr expr
+trfExpr' (HsPar expr) = AST.UParen <$> trfExpr expr
+trfExpr' (ExplicitTuple tupArgs box) | all tupArgPresent tupArgs 
+  = wrap <$> between AnnOpenP AnnCloseP (trfAnnList' ", " (trfExpr . (\(Present e) -> e) . unLoc) tupArgs)
+  where wrap = if box == Boxed then AST.UTuple else AST.UUnboxedTuple
+trfExpr' (ExplicitTuple tupArgs box)
+  = wrap <$> between AnnOpenP AnnCloseP
+               (do locs <- elemLocs
+                   makeList ", " atTheEnd $ mapM trfTupSecElem (zip (map unLoc tupArgs) locs))
+  where wrap = if box == Boxed then AST.UTupleSection else AST.UUnboxedTupSec
+        trfTupSecElem :: forall n r . TransformName n r => (HsTupArg n, SrcSpan) -> Trf (Ann AST.UTupSecElem (Dom r) RangeStage)
+        trfTupSecElem (Present e, l) 
+          = annLocNoSema (pure l) (AST.Present <$> (annCont createScopeInfo (trfExpr' (unLoc e))))
+        trfTupSecElem (Missing _, l) = annLocNoSema (pure l) (pure AST.Missing)
+        
+        elemLocs :: Trf [SrcSpan]
+        elemLocs = do r <- asks contRange
+                      commaLocs <- allTokenLoc AnnComma
+                      return $ foldl breakUp [r] commaLocs
+        breakUp :: [SrcSpan] -> SrcSpan -> [SrcSpan]
+        breakUp cont sep = concatMap (breakUpOne sep) cont
+
+        breakUpOne :: SrcSpan -> SrcSpan -> [SrcSpan]
+        breakUpOne sep@(RealSrcSpan realSep) sp@(RealSrcSpan realSp) 
+          | 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' (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 binds <*> trfExpr expr)
+trfExpr' (HsDo DoExpr (unLoc -> stmts) _) = AST.UDo <$> annLocNoSema (tokenLoc AnnDo) (pure AST.UDoKeyword) 
+                                                    <*> makeNonemptyIndentedList (trfScopedSequence trfDoStmt stmts)
+trfExpr' (HsDo MDoExpr (unLoc -> [unLoc -> RecStmt { recS_stmts = stmts }, lastStmt]) _) 
+  = AST.UDo <$> annLocNoSema (tokenLoc AnnMdo) (pure AST.UMDoKeyword)
+            <*> addToScope stmts (makeNonemptyIndentedList (mapM trfDoStmt (stmts ++ [lastStmt])))
+trfExpr' (HsDo MDoExpr (unLoc -> stmts) _) = AST.UDo <$> annLocNoSema (tokenLoc AnnMdo) (pure AST.UMDoKeyword)
+                                                     <*> addToScope stmts (makeNonemptyIndentedList (mapM trfDoStmt stmts))
+-- TODO: scoping
+trfExpr' (HsDo ListComp (unLoc -> stmts) _)
+  = AST.UListComp <$> trfExpr (getLastStmt stmts) <*> trfListCompStmts stmts
+trfExpr' (HsDo MonadComp (unLoc -> stmts) _)
+  = AST.UListComp <$> trfExpr (getLastStmt stmts) <*> trfListCompStmts stmts
+trfExpr' (HsDo PArrComp (unLoc -> stmts) _)
+  = AST.UParArrayComp <$> trfExpr (getLastStmt stmts) <*> trfListCompStmts stmts
+trfExpr' (ExplicitList _ _ exprs) = AST.UList <$> trfAnnList' ", " trfExpr exprs
+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' (ArithSeq _ _ (From from)) = AST.UEnum <$> trfExpr from <*> nothing "," "" (before AnnDotdot)
+                                                                <*> nothing "" "" (before AnnCloseS)
+trfExpr' (ArithSeq _ _ (FromThen from step)) 
+  = AST.UEnum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> nothing "" "" (before AnnCloseS) 
+trfExpr' (ArithSeq _ _ (FromTo from to)) 
+  = AST.UEnum <$> trfExpr from <*> nothing "," "" (before AnnDotdot)
+                               <*> (makeJust <$> trfExpr to)
+trfExpr' (ArithSeq _ _ (FromThenTo from step to)) 
+  = AST.UEnum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> (makeJust <$> trfExpr to)
+trfExpr' (PArrSeq _ (FromTo from to)) 
+  = AST.UParArrayEnum <$> trfExpr from <*> nothing "," "" (before AnnDotdot) <*> trfExpr to
+trfExpr' (PArrSeq _ (FromThenTo from step to)) 
+  = AST.UParArrayEnum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> trfExpr to
+-- TODO: SCC, CORE, GENERATED annotations
+trfExpr' (HsBracket brack) = AST.UBracketExpr <$> annContNoSema (trfBracket' brack)
+trfExpr' (HsSpliceE qq@(HsQuasiQuote {})) = AST.UQuasiQuoteExpr <$> annContNoSema (trfQuasiQuotation' qq)
+trfExpr' (HsSpliceE splice) = AST.USplice <$> annContNoSema (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' (HsAppType expr typ) = AST.UExplTypeApp <$> trfExpr expr <*> trfType (hswc_body typ)
+trfExpr' t = error ("Illegal expression: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")")
+  
+trfFieldInits :: TransformName n r => HsRecFields n (LHsExpr n) -> Trf (AnnListG AST.UFieldUpdate (Dom r) RangeStage)
+trfFieldInits (HsRecFields fields dotdot)
+  = do cont <- asks contRange
+       let (normalFlds, implicitFlds) = partition ((cont /=) . getLoc) fields
+       makeList ", " (before AnnCloseC)
+         $ ((++) <$> mapM trfFieldInit normalFlds
+                  <*> (if isJust dotdot then (:[]) <$> annLocNoSema (tokenLoc AnnDotdot) 
+                                                                    (AST.UFieldWildcard <$> (annCont (createImplicitFldInfo (unLoc . (\(HsVar n) -> n) . unLoc) (map unLoc implicitFlds)) (pure AST.FldWildcard))) 
+                                        else pure []))
+  
+trfFieldInit :: TransformName n r => Located (HsRecField n (LHsExpr n)) -> Trf (Ann AST.UFieldUpdate (Dom r) RangeStage)
+trfFieldInit = trfLocNoSema $ \case
+  HsRecField id _ True -> AST.UFieldPun <$> trfName (getFieldOccName id)
+  HsRecField id val False -> AST.UNormalFieldUpdate <$> trfName (getFieldOccName id) <*> trfExpr val
+  
+trfFieldUpdate :: TransformName n r => HsRecField' (AmbiguousFieldOcc n) (LHsExpr n) -> Trf (AST.UFieldUpdate (Dom r) RangeStage)
+trfFieldUpdate (HsRecField id _ True) = AST.UFieldPun <$> trfAmbiguousFieldName id
+trfFieldUpdate (HsRecField id val False) = AST.UNormalFieldUpdate <$> trfAmbiguousFieldName id <*> trfExpr val
+
+trfAlt :: TransformName n r => Located (Match n (LHsExpr n)) -> Trf (Ann AST.UAlt (Dom r) RangeStage)
+trfAlt = trfLocNoSema trfAlt'
+
+trfAlt' :: TransformName n r => Match n (LHsExpr n) -> Trf (AST.UAlt (Dom r) RangeStage)
+trfAlt' = gTrfAlt' trfExpr
+
+gTrfAlt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> Match n (Located (ge n)) -> Trf (AST.UAlt' ae (Dom r) RangeStage)
+gTrfAlt' te (Match _ [pat] typ (GRHSs rhss (unLoc -> locBinds)))
+  = AST.UAlt <$> trfPattern pat <*> gTrfCaseRhss te rhss <*> trfWhereLocalBinds locBinds
+  
+trfCaseRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.UCaseRhs (Dom r) RangeStage)
+trfCaseRhss = gTrfCaseRhss trfExpr
+
+gTrfCaseRhss :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> [Located (GRHS n (Located (ge n)))] -> Trf (Ann (AST.UCaseRhs' ae) (Dom r) RangeStage)
+gTrfCaseRhss te [unLoc -> GRHS [] body] = annLocNoSema (combineSrcSpans (getLoc body) <$> updateFocus (pure . updateEnd (const $ srcSpanStart $ getLoc body)) 
+                                                                                                      (tokenLocBack AnnRarrow)) 
+                                                 (AST.UUnguardedCaseRhs <$> te body)
+gTrfCaseRhss te rhss = annLocNoSema (pure $ collectLocs rhss) 
+                              (AST.UGuardedCaseRhss <$> trfAnnList ";" (gTrfGuardedCaseRhs' te) rhss)
+  
+trfGuardedCaseRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.UGuardedCaseRhs (Dom r) RangeStage)
+trfGuardedCaseRhs = trfLocNoSema trfGuardedCaseRhs' 
+
+trfGuardedCaseRhs' :: TransformName n r => GRHS n (LHsExpr n) -> Trf (AST.UGuardedCaseRhs (Dom r) RangeStage)
+trfGuardedCaseRhs' = gTrfGuardedCaseRhs' trfExpr
+
+gTrfGuardedCaseRhs' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> GRHS n (Located (ge n)) -> Trf (AST.UGuardedCaseRhs' ae (Dom r) RangeStage)
+gTrfGuardedCaseRhs' te (GRHS guards body) = AST.UGuardedCaseRhs <$> trfAnnList " " trfRhsGuard' guards <*> te body
+
+trfCmdTop :: TransformName n r => Located (HsCmdTop n) -> Trf (Ann AST.UCmd (Dom r) RangeStage)
+trfCmdTop (L _ (HsCmdTop cmd _ _ _)) = trfCmd cmd
+
+trfCmd :: TransformName n r => Located (HsCmd n) -> Trf (Ann AST.UCmd (Dom r) RangeStage)
+trfCmd = trfLocNoSema trfCmd'
+
+trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.UCmd (Dom r) RangeStage)
+trfCmd' (HsCmdArrApp left right _ typ dir) = AST.UArrowAppCmd <$> trfExpr left <*> op <*> trfExpr right 
+  where op = case (typ, dir) of (HsFirstOrderApp, False) -> annLocNoSema (tokenLoc Annrarrowtail) (pure AST.URightAppl)
+                                (HsFirstOrderApp, True) -> annLocNoSema (tokenLoc Annlarrowtail) (pure AST.ULeftAppl)
+                                (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' (HsCmdApp cmd expr) = AST.UAppCmd <$> trfCmd cmd <*> trfExpr expr
+trfCmd' (HsCmdLam (MG (unLoc -> [unLoc -> Match _ pats _ (GRHSs [unLoc -> GRHS [] body] _)]) _ _ _)) 
+  = AST.ULambdaCmd <$> trfAnnList " " trfPattern' pats <*> trfCmd body
+trfCmd' (HsCmdPar cmd) = AST.UParenCmd <$> trfCmd cmd
+trfCmd' (HsCmdCase expr (MG (unLoc -> alts) _ _ _)) 
+  = AST.UCaseCmd <$> trfExpr expr <*> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfAlt' trfCmd)) alts) 
+trfCmd' (HsCmdIf _ pred thenExpr elseExpr) = AST.UIfCmd <$> trfExpr pred <*> trfCmd thenExpr <*> trfCmd elseExpr
+trfCmd' (HsCmdLet (unLoc -> binds) cmd) = addToScope binds (AST.ULetCmd <$> trfLocalBinds binds <*> trfCmd cmd)
+trfCmd' (HsCmdDo (unLoc -> stmts) _) = AST.UDoCmd <$> makeNonemptyIndentedList (mapM (trfLocNoSema (gTrfDoStmt' trfCmd)) stmts)

+ Language/Haskell/Tools/AST/FromGHC/Exprs.hs-boot view

@@ -0,0 +1,15 @@+module Language.Haskell.Tools.AST.FromGHC.Exprs where
+
+import Outputable as GHC
+import RdrName as GHC
+import SrcLoc as GHC
+import HsExpr as GHC
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST (Ann(..), Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+
+trfExpr :: TransformName n r => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage)
+trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.UExpr (Dom r) RangeStage)
+trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.UCmd (Dom r) RangeStage)

+ Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs view

@@ -0,0 +1,216 @@+{-# LANGUAGE MultiParamTypeClasses
+           , TypeSynonymInstances
+           , FlexibleInstances
+           , ScopedTypeVariables
+           , ViewPatterns
+           , LambdaCase
+           #-}
+-- | Utility functions defined on the GHC AST representation.
+module Language.Haskell.Tools.AST.FromGHC.GHCUtils where
+
+import Data.List
+import qualified Data.Map as Map
+import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.Data
+
+import GHC
+import Bag
+import RdrName
+import OccName
+import Name
+import Outputable
+import SrcLoc
+import ConLike
+import Id
+import PatSyn
+import Type
+import TysWiredIn
+
+class OutputableBndr 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)
+  nameFromId :: Id -> name
+  unpackPostRn :: RdrName -> PostRn name name -> name
+
+  gunpackPostRn :: a -> (name -> a) -> PostRn name name -> a
+
+instance GHCName RdrName where
+  rdrName = id
+  getFromNameUsing _ n = return $ pure (nameRdrName n)
+  getBindsAndSigs (ValBindsIn binds sigs) = (sigs, binds)
+  nameFromId = nameRdrName . getName
+  unpackPostRn rdr _ = rdr
+
+  gunpackPostRn a _ _ = a
+
+occName :: GHCName n => n -> OccName
+occName = rdrNameOcc . rdrName 
+    
+instance GHCName GHC.Name where
+  rdrName = nameRdrName
+  getFromNameUsing f n = fmap nameFromId <$> f n
+  getBindsAndSigs (ValBindsOut bindGroups sigs) = (sigs, unionManyBags (map snd bindGroups))
+  nameFromId = getName
+  unpackPostRn _ a = a
+
+  gunpackPostRn _ f pr = f pr
+
+getFieldOccName :: GHCName n => Located (FieldOcc n) -> Located n
+getFieldOccName (L l (FieldOcc (L _ rdr) postRn)) = L l (unpackPostRn rdr postRn)
+
+getFieldOccName' :: GHCName n => FieldOcc n -> n
+getFieldOccName' (FieldOcc (L _ rdr) postRn) = unpackPostRn rdr postRn
+
+
+
+-- | Loading ids for top-level ghc names
+getTopLevelId :: GHC.Name -> Ghc (Maybe GHC.Id)
+getTopLevelId name = 
+    lookupName name >>= \case
+      Just (AnId id) -> return (Just id)
+      Just (AConLike (RealDataCon dc)) -> return $ Just $ mkVanillaGlobal name (dataConUserType dc)
+      Just (AConLike (PatSynCon ps)) -> return $ Just $ mkVanillaGlobal name (createPatSynType ps)
+      Just (ATyCon tc) -> return $ Just $ mkVanillaGlobal name (tyConKind tc)
+      Nothing -> return Nothing
+  where createPatSynType patSyn = case patSynSig patSyn of (_, _, _, _, args, res) -> mkFunTys args res
+
+-- | Get names from the GHC AST
+class HsHasName a where
+  hsGetNames :: a -> [GHC.Name]
+
+instance HsHasName RdrName where
+  hsGetNames _ = [] 
+
+instance HsHasName Name where
+  hsGetNames n = [n] 
+
+instance HsHasName Id where
+  hsGetNames n = [getName n] 
+
+instance HsHasName e => HsHasName [e] where
+  hsGetNames es = concatMap hsGetNames es
+
+instance HsHasName e => HsHasName (Located e) where
+  hsGetNames (L _ e) = hsGetNames e
+
+instance HsHasName n => HsHasName (HsLocalBinds n) where
+  hsGetNames (HsValBinds bnds) = hsGetNames bnds
+  hsGetNames _ = []
+
+instance (GHCName n, HsHasName n) => HsHasName (HsDecl n) where
+  hsGetNames (TyClD tycl) = hsGetNames tycl
+  hsGetNames (ValD vald) = hsGetNames vald
+  hsGetNames (ForD ford) = hsGetNames ford
+  hsGetNames _ = []
+
+instance (GHCName n, HsHasName n) => HsHasName (TyClGroup n) where
+  hsGetNames (TyClGroup tycls _) = hsGetNames tycls
+
+instance (GHCName n, HsHasName n) => HsHasName (TyClDecl n) where
+  hsGetNames (FamDecl (FamilyDecl {fdLName = name})) = hsGetNames name
+  hsGetNames (SynDecl {tcdLName = name}) = hsGetNames name
+  hsGetNames (DataDecl {tcdLName = name, tcdDataDefn = datadef}) = hsGetNames name ++ hsGetNames datadef
+  hsGetNames (ClassDecl {tcdLName = name, tcdSigs = sigs}) = hsGetNames name ++ hsGetNames sigs
+
+instance (GHCName n, HsHasName n) => HsHasName (HsDataDefn n) where
+  hsGetNames (HsDataDefn {dd_cons = ctors}) = hsGetNames ctors
+
+instance (GHCName n, HsHasName n) => HsHasName (ConDecl n) where
+  hsGetNames (ConDeclGADT {con_names = names, con_type = (HsIB _ (L l (HsRecTy flds)))}) = hsGetNames names ++ hsGetNames flds
+  hsGetNames (ConDeclGADT {con_names = names}) = hsGetNames names
+  hsGetNames (ConDeclH98 {con_name = name, con_details = details}) = hsGetNames name ++ hsGetNames details
+
+instance (GHCName n, HsHasName n) => HsHasName (HsConDeclDetails n) where
+  hsGetNames (RecCon rec) = hsGetNames rec
+  hsGetNames _ = []
+
+instance (GHCName n, HsHasName n) => HsHasName (ConDeclField n) where
+  hsGetNames (ConDeclField name _ _) = hsGetNames name
+
+instance (GHCName n, HsHasName n) => HsHasName (FieldOcc n) where 
+  hsGetNames (FieldOcc _ pr) = gunpackPostRn [] (hsGetNames :: n -> [Name]) pr
+
+instance (GHCName n, HsHasName n) => HsHasName (Sig n) where
+  hsGetNames (TypeSig n _) = hsGetNames n
+  hsGetNames (PatSynSig n _) = hsGetNames n
+  hsGetNames _ = []
+
+instance HsHasName n => HsHasName (ForeignDecl n) where
+  hsGetNames (ForeignImport n _ _ _) = hsGetNames n
+  hsGetNames _ = []
+
+instance HsHasName n => HsHasName (HsValBinds n) where
+  hsGetNames (ValBindsIn bnds _) = hsGetNames bnds
+  hsGetNames (ValBindsOut bnds _) = hsGetNames $ map snd bnds
+
+instance HsHasName n => HsHasName (Bag n) where
+  hsGetNames = hsGetNames . bagToList
+
+instance HsHasName n => HsHasName (HsBind n) where
+  hsGetNames (FunBind {fun_id = lname}) = hsGetNames lname
+  hsGetNames (PatBind {pat_lhs = pat}) = hsGetNames pat
+  hsGetNames (VarBind {var_id = id}) = hsGetNames id
+  hsGetNames (PatSynBind (PSB {psb_id = id})) = hsGetNames id
+
+instance HsHasName n => HsHasName (ParStmtBlock l n) where
+  hsGetNames (ParStmtBlock _ binds _) = hsGetNames binds
+
+--instance HsHasName n => HsHasName (LHsTyVarBndrs n) where
+--  hsGetNames (HsQTvs kvs tvs) = hsGetNames kvs ++ hsGetNames tvs
+
+instance HsHasName n => HsHasName (HsTyVarBndr n) where
+  hsGetNames (UserTyVar n) = hsGetNames n
+  hsGetNames (KindedTyVar n _) = hsGetNames n
+
+instance HsHasName n => HsHasName (Stmt n b) where
+  hsGetNames (LetStmt binds) = hsGetNames binds
+  hsGetNames (BindStmt pat _ _ _ _) = hsGetNames pat
+  hsGetNames (RecStmt {recS_rec_ids = ids}) = hsGetNames ids
+  hsGetNames _ = []
+
+instance HsHasName n => HsHasName (Pat n) where
+  hsGetNames (VarPat id) = hsGetNames id
+  hsGetNames (LazyPat p) = hsGetNames p
+  hsGetNames (AsPat lname p) = hsGetNames lname ++ hsGetNames p
+  hsGetNames (ParPat p) = hsGetNames p
+  hsGetNames (BangPat p) = hsGetNames p
+  hsGetNames (ListPat pats _ _) = concatMap hsGetNames pats
+  hsGetNames (TuplePat pats _ _) = concatMap hsGetNames pats
+  hsGetNames (PArrPat pats _) = concatMap hsGetNames pats
+  hsGetNames (ConPatIn _ details) = concatMap hsGetNames (hsConPatArgs details)
+  hsGetNames (ConPatOut {pat_args = details}) = concatMap hsGetNames (hsConPatArgs details)
+  hsGetNames (ViewPat _ p _) = hsGetNames p
+  hsGetNames (NPlusKPat lname _ _ _ _ _) = hsGetNames lname
+  hsGetNames (SigPatIn p _) = hsGetNames p
+  hsGetNames (SigPatOut p _) = hsGetNames p
+  hsGetNames _ = []
+
+instance (GHCName n, HsHasName n) => HsHasName (HsGroup n) where
+  hsGetNames (HsGroup vals _ clds _ _ _ _ foreigns _ _ _ _ _) = hsGetNames vals ++ hsGetNames clds ++ hsGetNames foreigns
+
+-- | Get the original form of a name
+rdrNameStr :: RdrName -> String
+rdrNameStr name = showSDocUnsafe $ ppr name
+
+-- | 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 :: OutputableBndr n => HsType n -> HsType n
+-- for some reason * is considered infix
+cleanHsType (HsAppsTy [unLoc -> HsAppInfix t]) = HsTyVar t
+cleanHsType (HsAppsTy apps) = unLoc $ guessType (splitHsAppsTy apps)
+  where guessType :: OutputableBndr n => ([[LHsType n]], [Located n]) -> LHsType n
+        guessType (term:terms, operator:operators)  
+          = let rhs = guessType (terms,operators)
+             in L (getLoc (head term) `combineSrcSpans` getLoc rhs) $ HsOpTy (doApps term) operator rhs
+        guessType ([term],[]) = doApps term
+        guessType x = error ("guessType: " ++ showSDocUnsafe (ppr x))
+        doApps term = foldl1 (\core t -> L (getLoc core `combineSrcSpans` getLoc t) $ HsAppTy core t) term
+cleanHsType t = t
+
+mergeFixityDefs :: [Located (FixitySig n)] -> [Located (FixitySig n)]
+mergeFixityDefs (s@(L l _) : rest) 
+  = let (same, different) = partition ((== l) . getLoc) rest 
+     in foldl mergeWith s (map unLoc same) : mergeFixityDefs different
+  where mergeWith (L l (FixitySig names fixity)) (FixitySig otherNames _) = L l (FixitySig (names ++ otherNames) fixity)
+mergeFixityDefs [] = []

+ Language/Haskell/Tools/AST/FromGHC/Kinds.hs view

@@ -0,0 +1,66 @@+{-# LANGUAGE ViewPatterns
+           , TypeFamilies 
+           #-}
+-- | Functions that convert the kind-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation
+module Language.Haskell.Tools.AST.FromGHC.Kinds where
+
+import SrcLoc as GHC
+import RdrName as GHC
+import HsTypes as GHC
+import OccName as GHC
+import Name as GHC
+import ApiAnnotation as GHC
+import Outputable as GHC
+import FastString as GHC
+
+import Control.Monad.Reader
+import Data.Data (toConstr)
+
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+import Language.Haskell.Tools.AST.FromGHC.Literals
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+
+import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), Dom, RangeStage, HasNoSemanticInfo)
+import qualified Language.Haskell.Tools.AST as AST
+
+import Debug.Trace
+
+trfKindSig :: TransformName n r => Maybe (LHsKind n) -> Trf (AnnMaybeG AST.UKindConstraint (Dom r) RangeStage)
+trfKindSig = trfMaybe "" "" trfKindSig'
+
+trfKindSig' :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.UKindConstraint (Dom r) RangeStage)
+trfKindSig' k = annLocNoSema (combineSrcSpans (getLoc k) <$> (tokenBefore (srcSpanStart (getLoc k)) AnnDcolon)) 
+                             (AST.UKindConstraint <$> trfLocNoSema trfKind' k)
+
+trfKind :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.UKind (Dom r) RangeStage)
+trfKind = trfLocNoSema (trfKind' . cleanHsType)
+
+trfKind' ::TransformName n r => HsKind n -> Trf (AST.UKind (Dom r) RangeStage)
+trfKind' = trfKind'' . cleanHsType where
+  trfKind'' (HsTyVar (rdrName . unLoc -> Exact n)) 
+    | isWiredInName n && occNameString (nameOccName n) == "*"
+    = pure AST.UStarKind
+    | isWiredInName n && occNameString (nameOccName n) == "#"
+    = pure AST.UUnboxKind
+  trfKind'' (HsParTy kind) = AST.UParenKind <$> trfKind kind
+  trfKind'' (HsFunTy k1 k2) = AST.UFunKind <$> trfKind k1 <*> trfKind k2
+  trfKind'' (HsAppTy k1 k2) = AST.UAppKind <$> trfKind k1 <*> trfKind k2
+  trfKind'' (HsTyVar kv) = transformingPossibleVar kv (AST.UVarKind <$> trfName kv)
+  trfKind'' (HsListTy kind) = AST.UListKind <$> trfKind kind
+  trfKind'' (HsAppsTy [unLoc -> HsAppPrefix t]) = trfKind' (unLoc t)
+  trfKind'' (HsAppsTy [unLoc -> HsAppInfix n]) = AST.UVarKind <$> trfName n
+  trfKind'' pt@(HsExplicitListTy {}) = AST.UPromotedKind <$> annContNoSema (trfPromoted' trfKind' pt) 
+  trfKind'' pt@(HsExplicitTupleTy {}) = AST.UPromotedKind <$> annContNoSema (trfPromoted' trfKind' pt) 
+  trfKind'' pt@(HsTyLit {}) = AST.UPromotedKind <$> annContNoSema (trfPromoted' trfKind' pt) 
+  trfKind'' k = error ("Illegal kind: " ++ showSDocUnsafe (ppr k) ++ " (ctor: " ++ show (toConstr k) ++ ")")
+
+trfPromoted' :: (TransformName n r, HasNoSemanticInfo (Dom r) a) 
+                  => (HsType n -> Trf (a (Dom r) RangeStage)) -> HsType n -> Trf (AST.UPromoted a (Dom r) RangeStage)
+trfPromoted' f (HsTyLit (HsNumTy _ int)) = pure $ AST.UPromotedInt int
+trfPromoted' f (HsTyLit (HsStrTy _ str)) = pure $ AST.UPromotedString (unpackFS str)
+trfPromoted' f (HsTyVar name) = AST.UPromotedCon <$> trfName name
+trfPromoted' f (HsExplicitListTy _ elems) = AST.UPromotedList <$> between AnnOpenS AnnCloseS (trfAnnList ", " f elems)
+trfPromoted' f (HsExplicitTupleTy _ elems) = AST.UPromotedTuple <$> between AnnOpenP AnnCloseP (trfAnnList ", " f elems)
+trfPromoted' _ t = asks contRange >>= \r -> error $ "Unknown promoted type/kind: " ++ (showSDocUnsafe (ppr t) ++ " at: " ++ show r)

+ Language/Haskell/Tools/AST/FromGHC/Literals.hs view

@@ -0,0 +1,38 @@+-- | Functions that convert the literals of the GHC AST to corresponding elements in the Haskell-tools AST representation
+module Language.Haskell.Tools.AST.FromGHC.Literals where
+
+import qualified Data.ByteString.Char8 as BS
+
+import SrcLoc as GHC
+import ApiAnnotation as GHC
+import FastString as GHC
+import BasicTypes as GHC
+import HsLit as GHC
+import HsTypes as GHC
+
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+
+import Language.Haskell.Tools.AST (Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+
+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)
+  
+trfOverloadedLit :: OverLitVal -> Trf (AST.ULiteral (Dom r) RangeStage)
+trfOverloadedLit (HsIntegral _ i) = pure $ AST.UIntLit i
+trfOverloadedLit (HsFractional frac) = pure $ AST.UFracLit (fl_value frac)
+trfOverloadedLit (HsIsString _ str) = pure $ AST.UStringLit (unpackFS str)

+ Language/Haskell/Tools/AST/FromGHC/Modules.hs view

@@ -0,0 +1,250 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , FlexibleContexts
+           , ScopedTypeVariables
+           , TypeApplications
+           , TupleSections
+           #-}
+-- | 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.AST.FromGHC.Modules where
+
+import Control.Reference hiding (element)
+import Data.Maybe
+import Data.Function (on)
+import Data.List as List
+import Data.Char
+import Data.Map as Map hiding (map, filter)
+import Data.IORef
+import Data.Data
+import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.Data
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+
+import Avail as GHC
+import GHC
+import GhcMonad as GHC
+import ApiAnnotation as GHC
+import RdrName as GHC
+import Name as GHC hiding (varName)
+import Id as GHC
+import TysWiredIn as GHC
+import SrcLoc as GHC
+import FastString as GHC
+import Module as GHC
+import BasicTypes as GHC
+import HsSyn as GHC
+import HscTypes as GHC
+import Outputable as GHC
+import TyCon as GHC
+import ConLike as GHC
+import DataCon as GHC
+import Bag as GHC
+import Var as GHC
+import PatSyn as GHC
+import Type as GHC
+import Unique as GHC
+import CoAxiom as GHC
+import DynFlags as GHC
+import TcEvidence as GHC
+import TcRnMonad as GHC
+import RnEnv as GHC
+import RnExpr as GHC
+import ErrUtils as GHC
+import PrelNames as GHC
+import NameEnv as GHC
+import TcRnDriver as GHC
+import TcExpr as GHC
+import TcType as GHC
+import UniqSupply as GHC
+import UniqFM as GHC
+import HeaderInfo as GHC
+import Language.Haskell.TH.LanguageExtensions
+
+import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG(..), AnnListG(..), Dom, IdDom, RangeStage
+                                  , semanticInfo, sourceInfo, semantics, annotation, nodeSpan, semaTraverse)
+import qualified Language.Haskell.Tools.AST as AST
+import Language.Haskell.Tools.AST.SemaInfoTypes as AST
+
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST.FromGHC.Decls
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+
+import Debug.Trace
+
+createModuleInfo :: ModSummary -> Trf (AST.ModuleInfo GHC.Name)
+createModuleInfo mod = do let prelude = xopt ImplicitPrelude $ ms_hspp_opts mod
+                          (_,preludeImports) <- if prelude then getImportedNames "Prelude" Nothing else return (ms_mod mod, [])
+                          return $ mkModuleInfo (ms_mod mod) (case ms_hsc_src mod of HsSrcFile -> False; _ -> True) preludeImports
+
+trfModule :: ModSummary -> Located (HsModule RdrName) -> Trf (Ann AST.UModule (Dom RdrName) RangeStage)
+trfModule mod = trfLocCorrect (createModuleInfo mod) (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) $ 
+                  \(HsModule name exports imports decls deprec _) -> 
+                    AST.UModule <$> trfFilePragmas
+                                <*> trfModuleHead name exports deprec
+                                <*> trfImports imports
+                                <*> trfDecls decls
+       
+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
+         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)
+        
+        trfModuleRename' preludeImports hsMod@(HsModule name exports _ decls deprec _) = do
+          transformedImports <- orderAnnList <$> (trfImports imports)
+           
+          addToScope (concat @[] (transformedImports ^? AST.annList&semantics&importedNames) ++ preludeImports)
+            $ loadSplices mod hsMod gr $ setOriginalNames originalNames . setDeclsToInsert roleAnnots
+              $ AST.UModule <$> trfFilePragmas
+                            <*> trfModuleHead name (case (exports, exps) of (Just (L l _), Just ie) -> Just (L l ie)
+                                                                            _                       -> Nothing) deprec
+                            <*> return transformedImports
+                            <*> trfDeclsGroup gr
+
+loadSplices :: ModSummary -> HsModule RdrName -> HsGroup Name -> Trf a -> Trf a
+loadSplices mod hsMod group trf = do 
+    let declSpls = map (\(SpliceDecl sp _) -> sp) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)]
+        declLocs = map getLoc declSpls
+    let exprSpls = catMaybes $ map (\case HsSpliceE sp -> Just sp; _ -> Nothing) $ hsMod ^? biplateRef :: [HsSplice RdrName]
+        typeSpls = catMaybes $ map (\case HsSpliceTy sp _ -> Just sp; _ -> Nothing) $ hsMod ^? biplateRef :: [HsSplice RdrName]
+    -- initialize reader environment
+    env <- liftGhc getSession
+
+    locals <- asks ((hsGetNames group ++) . concat . localsInScope)
+    let readEnv = mkOccEnv (map (\n -> (GHC.occName n, [GRE n NoParent False [ImpSpec (ImpDeclSpec (moduleName $ nameModule n) (moduleName $ nameModule n) False noSrcSpan) ImpAll]])) locals)
+
+    tcdSplices <- liftIO $ runTcInteractive env { hsc_dflags = xopt_set (hsc_dflags env) TemplateHaskellQuotes }
+      $ updGblEnv (\gbl -> gbl { tcg_rdr_env = readEnv }) 
+      $ (,,) <$> mapM tcHsSplice declSpls <*> mapM tcHsSplice' typeSpls <*> mapM tcHsSplice' exprSpls
+    let (declSplices, typeSplices, exprSplices) 
+          = fromMaybe (error $ "USplice expression could not be typechecked: " 
+                                 ++ showSDocUnsafe (vcat (pprErrMsgBagWithLoc (fst (fst tcdSplices))) 
+                                                      <+> vcat (pprErrMsgBagWithLoc (snd (fst tcdSplices))))) 
+                      (snd tcdSplices)
+    setSplices declSplices typeSplices exprSplices trf
+  where
+    tcHsSplice :: Located (HsSplice RdrName) -> RnM (Located (HsSplice Name))
+    tcHsSplice (L l s) = L l <$> tcHsSplice' s
+    tcHsSplice' (HsTypedSplice id e) 
+      = HsTypedSplice (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e)
+    tcHsSplice' (HsUntypedSplice id e) 
+      = HsUntypedSplice (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e)
+    tcHsSplice' (HsQuasiQuote id1 id2 sp fs) 
+      = pure $ HsQuasiQuote (mkUnboundNameRdr id1) (mkUnboundNameRdr id2) sp fs
+
+trfModuleHead :: TransformName n r => Maybe (Located ModuleName) -> Maybe (Located [LIE n]) -> Maybe (Located WarningTxt) -> Trf (AnnMaybeG AST.UModuleHead (Dom r) RangeStage) 
+trfModuleHead (Just mn) exports modPrag
+  = makeJust <$> (annLocNoSema (tokensLoc [AnnModule, AnnWhere])
+                               (AST.UModuleHead <$> trfModuleName mn 
+                                                <*> trfExportList (srcSpanEnd $ getLoc mn) exports
+                                                <*> trfModulePragma modPrag))
+trfModuleHead _ Nothing _ = nothing "" "" moduleHeadPos
+  where moduleHeadPos = after AnnClose >>= \case loc@(RealSrcLoc _) -> return loc
+                                                 _ -> atTheStart
+
+trfFilePragmas :: Trf (AnnListG AST.UFilePragma (Dom r) RangeStage)
+trfFilePragmas = do pragmas <- asks pragmaComms
+                    languagePragmas <- mapM trfLanguagePragma (fromMaybe [] $ (Map.lookup "LANGUAGE") pragmas)
+                    optionsPragmas <- mapM trfOptionsPragma (fromMaybe [] $ (Map.lookup "OPTIONS_GHC") pragmas)
+                    makeList "" atTheStart $ pure $ orderDefs $ languagePragmas ++ optionsPragmas
+
+trfLanguagePragma :: Located String -> Trf (Ann AST.UFilePragma (Dom r) RangeStage)
+trfLanguagePragma lstr@(L l str) = annLocNoSema (pure l) (AST.ULanguagePragma <$> makeList ", " (pure $ srcSpanStart $ getLoc $ last pragmaElems) 
+                                                                                                (mapM (trfLocNoSema (pure . AST.ULanguageExtension)) extensions))
+  where pragmaElems = splitLocated lstr
+        extensions = init $ drop 2 pragmaElems
+
+trfOptionsPragma :: Located String -> Trf (Ann AST.UFilePragma (Dom r) RangeStage)
+trfOptionsPragma (L l str) = annLocNoSema (pure l) (AST.UOptionsPragma <$> annContNoSema (pure $ AST.UStringNode str))
+
+trfModulePragma :: Maybe (Located WarningTxt) -> Trf (AnnMaybeG AST.UModulePragma (Dom r) RangeStage)
+trfModulePragma = trfMaybeDefault " " "" (trfLocNoSema $ \case WarningTxt _ txts -> AST.UModuleWarningPragma <$> trfAnnList " " trfText' txts
+                                                               DeprecatedTxt _ txts -> AST.UModuleDeprecatedPragma <$> trfAnnList " " trfText' txts) 
+                                  (before AnnWhere)
+
+trfText' :: StringLiteral -> Trf (AST.UStringNode (Dom r) RangeStage)
+trfText' = pure . AST.UStringNode . unpackFS . sl_fs
+
+
+
+trfExportList :: TransformName n r => SrcLoc -> Maybe (Located [LIE n]) -> Trf (AnnMaybeG AST.UExportSpecs (Dom r) RangeStage)
+trfExportList loc = trfMaybeDefault " " "" (trfLocNoSema trfExportList') (pure loc)
+
+trfExportList' :: TransformName n r => [LIE n] -> Trf (AST.UExportSpecs (Dom r) RangeStage)
+trfExportList' exps = AST.UExportSpecs <$> (makeList ", " (after AnnOpenP) (orderDefs . catMaybes <$> (mapM trfExport exps)))
+  
+trfExport :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.UExportSpec (Dom r) RangeStage))
+trfExport = trfMaybeLocNoSema $ \case 
+  IEModuleContents n -> Just . AST.UModuleExport <$> (trfModuleName n)
+  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 (filter (not . ideclImplicit . unLoc) -> imps) 
+  = AnnListG <$> importDefaultLoc <*> mapM trfImport imps
+  where importDefaultLoc = noSemaInfo . AST.ListPos (if List.null imps then "\n" else "") "" "\n" True . 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 src name pkg isSrc isSafe isQual isImpl declAs declHiding)) =
+  let -- default positions of optional parts of an import declaration
+      annBeforeQual = if isSrc then AnnClose else AnnImport
+      annBeforeSafe = if isQual then AnnQualified else annBeforeQual
+      annBeforePkg = if isSafe then AnnSafe else annBeforeSafe
+  in annLoc (createImportData impDecl) (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)) 
+                      else nothing " " "" (after annBeforeQual))
+       <*> (if isSafe then makeJust <$> (annLocNoSema (tokenLoc AnnSafe) (pure AST.UImportSafe)) 
+                      else nothing " " "" (after annBeforeSafe))
+       <*> maybe (nothing " " "" (after annBeforePkg)) 
+                 (\str -> makeJust <$> (annLocNoSema (tokenLoc AnnPackageName) (pure (AST.UStringNode (unpackFS $ sl_fs str))))) pkg
+       <*> 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)))  
+  
+trfImportSpecs :: TransformName n r => Maybe (Bool, Located [LIE n]) -> Trf (AnnMaybeG AST.UImportSpec (Dom r) RangeStage)
+trfImportSpecs (Just (True, l)) 
+  = makeJust <$> trfLocNoSema (\specs -> AST.UImportSpecHiding <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l
+trfImportSpecs (Just (False, l)) 
+  = makeJust <$> trfLocNoSema (\specs -> AST.UImportSpecList <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l
+trfImportSpecs Nothing = nothing " " "" atTheEnd
+    
+trfIESpec :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.UIESpec (Dom r) RangeStage)) 
+trfIESpec = trfMaybeLocNoSema trfIESpec'
+  
+trfIESpec' :: TransformName n r => IE n -> Trf (Maybe (AST.UIESpec (Dom r) RangeStage))
+trfIESpec' (IEVar n) = Just <$> (AST.UIESpec <$> trfName n <*> (nothing "(" ")" atTheEnd))
+trfIESpec' (IEThingAbs n) = Just <$> (AST.UIESpec <$> trfName n <*> (nothing "(" ")" atTheEnd))
+trfIESpec' (IEThingAll n) 
+  = Just <$> (AST.UIESpec <$> trfName n <*> (makeJust <$> (annLocNoSema (tokenLoc AnnDotdot) (pure AST.USubSpecAll))))
+trfIESpec' (IEThingWith n _ ls _)
+  = Just <$> (AST.UIESpec <$> trfName n
+                          <*> (makeJust <$> between AnnOpenP AnnCloseP 
+                                                   (annContNoSema $ AST.USubSpecList <$> makeList ", " (after AnnOpenP) (mapM trfName ls))))
+trfIESpec' _ = pure Nothing
+  
+trfModuleName :: Located ModuleName -> Trf (Ann AST.UModuleName (Dom r) RangeStage)
+trfModuleName = trfLocNoSema trfModuleName'
+
+trfModuleName' :: ModuleName -> Trf (AST.UModuleName (Dom r) RangeStage)
+trfModuleName' = pure . AST.UModuleName . moduleNameString 
+

+ Language/Haskell/Tools/AST/FromGHC/Monad.hs view

@@ -0,0 +1,117 @@+-- | 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.AST.FromGHC.Monad where
+
+import SrcLoc
+import GHC
+import Name
+import ApiAnnotation
+import Outputable (ppr, showSDocUnsafe)
+import Control.Monad.Reader
+import Language.Haskell.Tools.AST.FromGHC.SourceMap
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+import Data.Map as Map
+import Data.Function (on)
+import Data.Maybe
+import Language.Haskell.Tools.AST
+
+import Debug.Trace
+
+-- | The transformation monad type
+type Trf = ReaderT TrfInput Ghc
+
+-- | The (immutable) data for the transformation
+data TrfInput
+  = TrfInput { srcMap :: SourceMap -- ^ The lexical tokens of the source file
+             , pragmaComms :: Map String [Located String] -- ^ Pragma comments
+             , declsToInsert :: [Ann UDecl (Dom RdrName) RangeStage] -- ^ Declarations that are from the parsed AST
+             , contRange :: SrcSpan -- ^ The focus of the transformation
+             , localsInScope :: [[GHC.Name]] -- ^ Local names visible
+             , defining :: Bool -- ^ True, if names are defined in the transformed AST element.
+             , definingTypeVars :: Bool -- ^ True, if type variable names are defined in the transformed AST element.
+             , originalNames :: Map SrcSpan RdrName -- ^ Stores the original format of names.
+             , declSplices :: [Located (HsSplice GHC.Name)] -- ^ Location of the TH splices for extracting declarations from the renamed AST. 
+                 -- ^ It is possible that multiple declarations stand in the place of the declaration splice or none at all.
+             , typeSplices :: [HsSplice GHC.Name] -- ^ Other types of splices (expressions, types). 
+             , exprSplices :: [HsSplice GHC.Name] -- ^ Other types of splices (expressions, types). 
+             }
+      
+trfInit :: Map ApiAnnKey [SrcSpan] -> Map String [Located String] -> TrfInput
+trfInit annots comments 
+  = TrfInput { srcMap = annotationsToSrcMap annots
+             , pragmaComms = comments
+             , declsToInsert = []
+             , contRange = noSrcSpan
+             , localsInScope = []
+             , defining = False
+             , definingTypeVars = False
+             , originalNames = empty
+             , declSplices = []
+             , typeSplices = []
+             , exprSplices = []
+             }
+
+liftGhc :: Ghc a -> Trf a
+liftGhc = lift
+
+-- | Perform the transformation taking names as defined.
+define :: Trf a -> Trf a
+define = local (\s -> s { defining = True })
+
+-- | Perform the transformation taking type variable names as defined.
+defineTypeVars :: Trf a -> Trf a
+defineTypeVars = local (\s -> s { definingTypeVars = True })
+
+-- | Transform as type variables
+typeVarTransform :: Trf a -> Trf a
+typeVarTransform = local (\s -> s { defining = defining s || definingTypeVars s })
+
+-- | Transform a name as a type variable if it is one.
+transformingPossibleVar :: HsHasName n => n -> Trf a -> Trf a
+transformingPossibleVar n = case hsGetNames n of 
+  [name] | isVarName name || isTyVarName name -> typeVarTransform
+  _                                           -> id
+
+-- | Perform the transformation putting the given definition in a new local scope.
+addToScope :: HsHasName e => e -> Trf a -> Trf a
+addToScope e = local (\s -> s { localsInScope = hsGetNames e : localsInScope s }) 
+
+-- | Perform the transformation putting the given definitions in the current scope.
+addToCurrentScope :: HsHasName e => e -> Trf a -> Trf a
+addToCurrentScope e = local (\s -> s { localsInScope = case localsInScope s of lastScope:rest -> (hsGetNames e ++ lastScope):rest
+                                                                               []             -> [hsGetNames e] })
+
+-- | Performs the transformation given the tokens of the source file
+runTrf :: Map ApiAnnKey [SrcSpan] -> Map String [Located String] -> Trf a -> Ghc a
+runTrf annots comments trf = runReaderT trf (trfInit annots comments)
+
+setOriginalNames :: Map SrcSpan RdrName -> Trf a -> Trf a
+setOriginalNames names = local (\s -> s { originalNames = names })
+
+-- | Get the original format of a name (before scoping).
+getOriginalName :: RdrName -> Trf String
+getOriginalName n = do sp <- asks contRange
+                       asks (rdrNameStr . fromMaybe n . (Map.lookup sp) . originalNames)
+
+-- | Set splices that must replace the elements that are generated into the AST representation.
+setSplices :: [Located (HsSplice GHC.Name)] -> [HsSplice GHC.Name] -> [HsSplice GHC.Name] -> Trf a -> Trf a
+setSplices declSpls typeSpls exprSpls 
+  = local (\s -> s { typeSplices = typeSpls, exprSplices = exprSpls, declSplices = declSpls })
+
+-- | Set the list of declarations that will be missing from AST
+setDeclsToInsert :: [Ann UDecl (Dom RdrName) RangeStage] -> Trf a -> Trf a
+setDeclsToInsert decls = local (\s -> s {declsToInsert = decls})
+
+-- Remove the splice that has already been added
+exprSpliceInserted :: HsSplice GHC.Name -> Trf a -> Trf a
+exprSpliceInserted spl = local (\s -> s { exprSplices = Prelude.filter (((/=) `on` getSpliceLoc) spl) (exprSplices s) })
+
+-- Remove the splice that has already been added
+typeSpliceInserted :: HsSplice GHC.Name -> Trf a -> Trf a
+typeSpliceInserted spl = local (\s -> s { typeSplices = Prelude.filter (((/=) `on` getSpliceLoc) spl) (typeSplices s) })
+
+
+getSpliceLoc :: HsSplice a -> SrcSpan
+getSpliceLoc (HsTypedSplice _ e) = getLoc e
+getSpliceLoc (HsUntypedSplice _ e) = getLoc e
+getSpliceLoc (HsQuasiQuote _ _ sp _) = sp

+ Language/Haskell/Tools/AST/FromGHC/Names.hs view

@@ -0,0 +1,145 @@+{-# LANGUAGE LambdaCase
+           , TupleSections
+           , TypeFamilies
+           , FlexibleInstances
+           , FlexibleContexts
+           , TypeSynonymInstances
+           , ScopedTypeVariables
+           , MultiParamTypeClasses
+           , UndecidableInstances
+           , AllowAmbiguousTypes
+           , TypeApplications
+           #-}
+-- | Functions that convert the basic elements of the GHC AST to corresponding elements in the Haskell-tools AST representation
+module Language.Haskell.Tools.AST.FromGHC.Names where
+
+import Control.Monad.Reader
+import Data.List.Split
+import Data.Char
+import qualified Data.ByteString.Char8 as BS
+
+import Control.Reference hiding (element)
+
+import HsSyn as GHC
+import Module as GHC
+import RdrName as GHC
+import Id as GHC
+import Name as GHC hiding (Name, occName)
+import qualified Name as GHC (Name)
+import Outputable as GHC
+import SrcLoc as GHC
+import BasicTypes as GHC
+import FastString as GHC
+import ApiAnnotation as GHC
+import ForeignCall as GHC
+import CoAxiom as GHC
+import Bag as GHC
+import Data.Data (Data)
+
+import Language.Haskell.Tools.AST (Ann(..), AnnListG(..), AnnMaybeG(..), SemanticInfo(..), RangeStage, Dom, annotation, semanticInfo)
+import qualified Language.Haskell.Tools.AST as AST
+
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+
+trfOperator :: TransformName n r => Located n -> Trf (Ann AST.UOperator (Dom r) RangeStage)
+trfOperator = trfLocNoSema trfOperator'
+
+trfOperator' :: TransformName n r => n -> Trf (AST.UOperator (Dom r) RangeStage)
+trfOperator' n
+  | isSymOcc (occName n) = AST.UNormalOp <$> (annCont (createNameInfo (transformName n)) (trfQualifiedName' n))
+  | otherwise = AST.UBacktickOp <$> (annLoc (createNameInfo (transformName n)) loc (trfQualifiedName' n))
+     where loc = mkSrcSpan <$> (updateCol (+1) <$> atTheStart) <*> (updateCol (subtract 1) <$> atTheEnd)
+
+trfName :: TransformName n r => Located n -> Trf (Ann AST.UName (Dom r) RangeStage)
+trfName = trfLocNoSema trfName'
+
+trfName' :: TransformName n r => n -> Trf (AST.UName (Dom r) RangeStage)
+trfName' n
+  | isSymOcc (occName n) = AST.UParenName <$> (annLoc (createNameInfo (transformName n)) loc (trfQualifiedName' n))
+  | otherwise = AST.UNormalName <$> (annCont (createNameInfo (transformName n)) (trfQualifiedName' n))
+     where loc = mkSrcSpan <$> (updateCol (+1) <$> atTheStart) <*> (updateCol (subtract 1) <$> atTheEnd)
+
+trfAmbiguousFieldName :: TransformName n r => Located (AmbiguousFieldOcc n) -> Trf (Ann AST.UName (Dom r) RangeStage)
+trfAmbiguousFieldName all@(L l af) = trfAmbiguousFieldName' l af
+
+trfAmbiguousFieldName' :: forall n r . TransformName n r => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.UName (Dom r) RangeStage)
+trfAmbiguousFieldName' l (Unambiguous (L _ rdr) pr) = annLocNoSema (pure l) $ trfName' (unpackPostRn @n rdr pr)
+-- no Id transformation is done, so we can basically ignore the postTC value
+trfAmbiguousFieldName' _ (Ambiguous (L l rdr) _) 
+  = do locals <- asks localsInScope
+       isDefining <- asks defining
+       annLocNoSema (pure l) 
+         $ AST.UNormalName 
+         <$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfNameStr (rdrNameStr rdr))
+
+class (DataId n, Eq n, GHCName n) => TransformableName n where
+  correctNameString :: n -> Trf String
+  getDeclSplices :: Trf [Located (HsSplice n)]
+  fromGHCName :: GHC.Name -> n 
+
+instance TransformableName RdrName where
+  correctNameString = pure . rdrNameStr
+  getDeclSplices = pure []
+  fromGHCName = rdrName
+
+instance TransformableName GHC.Name where
+  correctNameString n = getOriginalName (rdrName n)
+  getDeclSplices = asks declSplices
+  fromGHCName = id
+
+-- | This class allows us to use the same transformation code for multiple variants of the GHC AST.
+-- GHC UName annotated with 'name' can be transformed to our representation with semantic annotations of 'res'.
+class (TransformableName name, HsHasName name, TransformableName res, HsHasName res, GHCName res) 
+        => TransformName name res where
+  -- | Demote a given name
+  transformName :: name -> res
+
+instance {-# OVERLAPPABLE #-} (n ~ r, TransformableName n, HsHasName n) => TransformName n r where
+  transformName = id
+
+instance {-# OVERLAPS #-} (TransformableName res, GHCName res, HsHasName res) => TransformName GHC.Name res where
+  transformName = fromGHCName
+
+trfImplicitName :: HsIPName -> Trf (Ann AST.UName (Dom r) RangeStage)
+trfImplicitName (HsIPName fs) 
+  = let nstr = unpackFS fs 
+     in do rng <- asks contRange
+           let rng' = mkSrcSpan (updateCol (+1) (srcSpanStart rng)) (srcSpanEnd rng)
+           annContNoSema (AST.UImplicitName <$> annLoc (createImplicitNameInfo nstr) (pure rng') (AST.nameFromList <$> trfNameStr nstr))
+
+trfQualifiedName :: TransformName n r => Located n -> Trf (Ann AST.UQualifiedName (Dom r) RangeStage)
+trfQualifiedName name@(L l n) = annLoc (createNameInfo (transformName n)) (pure l) (trfQualifiedName' n)
+
+trfQualifiedName' :: TransformName n r => n -> Trf (AST.UQualifiedName (Dom r) RangeStage)
+trfQualifiedName' n = AST.nameFromList <$> (trfNameStr =<< correctNameString n)
+
+-- | Creates a qualified name from a name string
+trfNameStr :: String -> Trf (AnnListG AST.UNamePart (Dom r) RangeStage)
+trfNameStr str = makeList "." atTheStart (trfNameStr' str <$> atTheStart)
+
+trfNameStr' :: String -> SrcLoc -> [Ann AST.UNamePart (Dom r) RangeStage]
+trfNameStr' str srcLoc = fst $
+  foldl (\(r,loc) np -> let nextLoc = advanceAllSrcLoc loc np
+                         in ( r ++ [Ann (noSemaInfo $ AST.NodeSpan (mkSrcSpan loc nextLoc)) (AST.UNamePart np)], advanceAllSrcLoc nextLoc "." ) ) 
+  ([], srcLoc) (nameParts str)
+  where -- | Move the source location according to a string
+        advanceAllSrcLoc :: SrcLoc -> String -> SrcLoc
+        advanceAllSrcLoc (RealSrcLoc rl) str = RealSrcLoc $ foldl advanceSrcLoc rl str
+        advanceAllSrcLoc oth _ = oth
+
+        -- | Break up a name into parts, but take care for operators
+        nameParts :: String -> [String]
+        nameParts = nameParts' ""
+
+        nameParts' :: String -> String -> [String]
+        nameParts' carry (c : rest) | isLetter c || isDigit c || c == '\'' || c == '_' || c == '#'
+                                    = nameParts' (c:carry) rest
+        nameParts' carry@(_:_) ('.' : rest) = reverse carry : nameParts rest
+        nameParts' "" rest = [rest] 
+        nameParts' carry [] = [reverse carry]
+        nameParts' carry str = error $ "nameParts': " ++ show carry ++ " " ++ show str
+
+trfFastString :: Located FastString -> Trf (Ann AST.UStringNode (Dom r) RangeStage)
+trfFastString = trfLocNoSema $ pure . AST.UStringNode . unpackFS

+ Language/Haskell/Tools/AST/FromGHC/Patterns.hs view

@@ -0,0 +1,71 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , ScopedTypeVariables
+           , AllowAmbiguousTypes
+           #-}
+-- | Functions that convert the pattern-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation
+module Language.Haskell.Tools.AST.FromGHC.Patterns where
+
+import SrcLoc as GHC
+import RdrName as GHC
+import HsTypes as GHC
+import HsPat as GHC
+import HsLit as GHC
+import ApiAnnotation as GHC
+import BasicTypes as GHC
+import Unique as GHC
+import Debug.Trace
+import Data.List
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+
+import Language.Haskell.Tools.AST.FromGHC.Names
+import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH
+import Language.Haskell.Tools.AST.FromGHC.Literals
+import Language.Haskell.Tools.AST.FromGHC.Types
+import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Exprs
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+
+import Language.Haskell.Tools.AST (Ann(..), Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+
+trfPattern :: TransformName n r => Located (Pat n) -> Trf (Ann AST.UPattern (Dom r) RangeStage)
+-- field wildcards are not directly represented in GHC AST
+trfPattern (L l (ConPatIn name (RecCon (HsRecFields flds _)))) | any ((l ==) . getLoc) flds 
+  = do let (fromWC, notWC) = partition ((l ==) . getLoc) flds
+       normalFields <- mapM (trfLocNoSema trfPatternField') notWC
+       wildc <- annLocNoSema (tokenLoc AnnDotdot) (AST.UFieldWildcardPattern <$> annCont (createImplicitFldInfo (unLoc . (\(VarPat n) -> n) . unLoc) (map unLoc fromWC)) (pure AST.FldWildcard))
+       annLocNoSema (pure l) (AST.URecPat <$> trfName name <*> makeNonemptyList ", " (pure (normalFields ++ [wildc])))
+trfPattern p | otherwise = trfLocNoSema trfPattern' (correctPatternLoc p)
+
+-- | Locations for right-associative infix patterns are incorrect in GHC AST
+correctPatternLoc :: Located (Pat n) -> Located (Pat n)
+correctPatternLoc (L l p@(ConPatIn name (InfixCon left right)))
+  = L (getLoc (correctPatternLoc left) `combineSrcSpans` getLoc (correctPatternLoc right)) p
+correctPatternLoc p = p
+
+trfPattern' :: TransformName n r => Pat n -> Trf (AST.UPattern (Dom r) RangeStage)
+trfPattern' (WildPat _) = pure AST.UWildPat
+trfPattern' (VarPat name) = define $ AST.UVarPat <$> trfName name
+trfPattern' (LazyPat pat) = AST.UIrrefutablePat <$> trfPattern pat
+trfPattern' (AsPat name pat) = AST.UAsPat <$> define (trfName name) <*> trfPattern pat
+trfPattern' (ParPat pat) = AST.UParenPat <$> trfPattern pat
+trfPattern' (BangPat pat) = AST.UBangPat <$> trfPattern pat
+trfPattern' (ListPat pats _ _) = AST.UListPat <$> trfAnnList ", " trfPattern' pats
+trfPattern' (TuplePat pats Boxed _) = AST.UTuplePat <$> trfAnnList ", " trfPattern' pats
+trfPattern' (PArrPat pats _) = AST.UParArrPat <$> trfAnnList ", " trfPattern' pats
+trfPattern' (ConPatIn name (PrefixCon args)) = AST.UAppPat <$> trfName name <*> trfAnnList " " trfPattern' args
+trfPattern' (ConPatIn name (RecCon (HsRecFields flds _))) = AST.URecPat <$> trfName name <*> trfAnnList ", " trfPatternField' flds
+trfPattern' (ConPatIn name (InfixCon left right)) = AST.UInfixAppPat <$> trfPattern left <*> trfOperator name <*> trfPattern right
+trfPattern' (ViewPat expr pat _) = AST.UViewPat <$> trfExpr expr <*> trfPattern pat
+trfPattern' (SplicePat splice) = AST.USplicePat <$> annContNoSema (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' (NPat (ol_val . unLoc -> lit) _ _ _) = AST.ULitPat <$> annContNoSema (trfOverloadedLit lit)
+trfPattern' (NPlusKPat id (L l lit) _ _ _ _) = AST.UNPlusKPat <$> define (trfName id) <*> annLocNoSema (pure l) (trfOverloadedLit (ol_val lit))
+-- coercion pattern introduced by GHC
+trfPattern' (CoPat _ pat _) = trfPattern' pat
+
+trfPatternField' :: TransformName n r => HsRecField n (LPat n) -> Trf (AST.UPatternField (Dom r) RangeStage)
+trfPatternField' (HsRecField id arg False) = AST.UNormalFieldPattern <$> trfName (getFieldOccName id) <*> trfPattern arg
+trfPatternField' (HsRecField id _ True) = AST.UFieldPunPattern <$> trfName (getFieldOccName id)

+ Language/Haskell/Tools/AST/FromGHC/SourceMap.hs view

@@ -0,0 +1,61 @@+{-# LANGUAGE TupleSections #-}
+-- | A representation of the tokens that build up the source file.
+module Language.Haskell.Tools.AST.FromGHC.SourceMap where
+
+import ApiAnnotation
+import Data.Maybe
+import Data.Map as Map
+import Data.List as List
+import Safe
+
+import SrcLoc as GHC
+import FastString as GHC
+
+-- We store tokens in the source map so it is not a problem that they cannot overlap
+type SourceMap = (Map AnnKeywordId (Map SrcLoc SrcLoc), Map SrcLoc (SrcSpan, AnnKeywordId))
+
+-- | Returns the first occurrence of the keyword in the whole source file
+getKeywordAnywhere :: AnnKeywordId -> SourceMap -> Maybe SrcSpan
+getKeywordAnywhere keyw srcmap = return . uncurry mkSrcSpan =<< headMay . assocs =<< (Map.lookup keyw (fst srcmap))
+
+-- | Get the source location of a token restricted to a certain source span
+getKeywordInside :: AnnKeywordId -> SrcSpan -> SourceMap -> Maybe SrcSpan
+getKeywordInside keyw sr srcmap = getSourceElementInside True sr =<< Map.lookup keyw (fst srcmap)
+
+getKeywordsInside :: AnnKeywordId -> SrcSpan -> SourceMap -> [SrcSpan]
+getKeywordsInside keyw sr srcmap 
+  = let tokensOfType = Map.lookup keyw (fst srcmap)
+        (_, startsAtBegin, startAfterBegin) = Map.splitLookup (srcSpanStart sr) $ fromMaybe empty tokensOfType
+        (startsBeforeEnd, _) = Map.split (srcSpanEnd sr) $ maybe id (Map.insert (srcSpanStart sr)) startsAtBegin startAfterBegin -- tokens are minimum 1 char long
+     in List.map (uncurry mkSrcSpan) $ List.filter (\(_, end) -> end <= srcSpanEnd sr) $ assocs startsBeforeEnd
+
+getKeywordInsideBack :: AnnKeywordId -> SrcSpan -> SourceMap -> Maybe SrcSpan
+getKeywordInsideBack keyw sr srcmap = getSourceElementInside False sr =<< Map.lookup keyw (fst srcmap)
+
+getSourceElementInside :: Bool -> SrcSpan -> Map SrcLoc SrcLoc -> Maybe SrcSpan
+getSourceElementInside b sr srcmap = 
+  case (if b then lookupGE (srcSpanStart sr) else lookupLT (srcSpanEnd sr)) srcmap of
+    Just (k, v) -> let sp = mkSrcSpan k v in if sp `isSubspanOf` sr then Just sp else Nothing
+    Nothing -> Nothing
+
+-- | Returns the next token on the token stream (including the token that starts on the given location)
+getNextToken :: SrcLoc -> SourceMap -> Maybe (SrcSpan, AnnKeywordId)
+getNextToken loc srcmap = fmap snd $ Map.lookupGE loc $ snd srcmap
+
+-- | Returns all subsequent tokens (including the token that starts on the given location)
+getTokensAfter :: SrcLoc -> SourceMap -> [(SrcSpan, AnnKeywordId)]
+getTokensAfter loc srcmap = case Map.splitLookup loc $ snd srcmap of 
+    (_, Just elem, after) -> elem : elems after
+    (_, Nothing, after) -> elems after
+    
+-- | Converts GHC Annotations into a convenient format for looking up tokens
+annotationsToSrcMap :: Map ApiAnnKey [SrcSpan] -> SourceMap
+annotationsToSrcMap anns = (Map.map (List.foldr addToSrcRanges Map.empty) $ mapKeysWith (++) snd anns, tokenMap)
+  where 
+    addToSrcRanges :: SrcSpan -> Map SrcLoc SrcLoc -> Map SrcLoc SrcLoc
+    addToSrcRanges span srcmap = Map.insert (srcSpanStart span) (srcSpanEnd span) srcmap
+
+    tokenMap = Map.fromList $ List.map (\(k,v) -> (srcSpanStart k, (k, v))) $ concatMap (\(key,vals) -> List.map ((, snd key)) vals) $ Map.assocs anns
+    
+    
+

+ Language/Haskell/Tools/AST/FromGHC/Stmts.hs view

@@ -0,0 +1,81 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , TypeFamilies
+           #-}
+-- | Functions that convert the statement-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation
+module Language.Haskell.Tools.AST.FromGHC.Stmts where
+ 
+import Data.Maybe
+import Control.Monad.Reader
+
+import SrcLoc as GHC
+import RdrName as GHC
+import HsTypes as GHC
+import HsPat as GHC
+import HsExpr as GHC
+import ApiAnnotation as GHC
+
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST.FromGHC.Types
+import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Exprs
+import Language.Haskell.Tools.AST.FromGHC.Patterns
+import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.Binds
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+
+import Language.Haskell.Tools.AST (Ann(..), AnnListG(..), AnnMaybeG(..), Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+ 
+trfDoStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.UStmt (Dom r) RangeStage)
+trfDoStmt = trfLocNoSema trfDoStmt'
+
+trfDoStmt' :: TransformName n r => Stmt n (Located (HsExpr n)) -> Trf (AST.UStmt' AST.UExpr (Dom r) RangeStage)
+trfDoStmt' = gTrfDoStmt' trfExpr
+
+gTrfDoStmt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae (Dom r) RangeStage)) -> Stmt n (Located (ge n)) -> Trf (AST.UStmt' ae (Dom r) RangeStage)
+gTrfDoStmt' et (BindStmt pat expr _ _ _) = AST.UBindStmt <$> trfPattern pat <*> et expr
+gTrfDoStmt' et (BodyStmt expr _ _ _) = AST.UExprStmt <$> et expr
+gTrfDoStmt' et (LetStmt (unLoc -> binds)) = AST.ULetStmt <$> addToScope binds (trfLocalBinds binds)
+gTrfDoStmt' et (LastStmt body _ _) = AST.UExprStmt <$> et body
+gTrfDoStmt' et (RecStmt { recS_stmts = stmts }) = AST.URecStmt <$> trfAnnList "," (gTrfDoStmt' et) stmts
+
+trfListCompStmts :: TransformName n r => [Located (Stmt n (LHsExpr n))] -> Trf (AnnListG AST.UListCompBody (Dom r) RangeStage)
+trfListCompStmts [unLoc -> ParStmt blocks _ _ _, unLoc -> (LastStmt {})]
+  = nonemptyAnnList
+      <$> trfScopedSequence (\(ParStmtBlock stmts _ _) -> 
+                                let ann = collectLocs $ getNormalStmts stmts
+                                 in annLocNoSema (pure ann) (AST.UListCompBody <$> makeList "," (pure $ srcSpanStart ann) (concat <$> trfScopedSequence trfListCompStmt stmts))
+                            ) blocks
+trfListCompStmts others 
+  = let ann = (collectLocs $ getNormalStmts others)
+     in makeList "|" (pure $ srcSpanStart ann)
+          ((:[]) <$> annLocNoSema (pure ann)
+                                  (AST.UListCompBody <$> makeList "," (pure $ srcSpanStart ann) (concat <$> trfScopedSequence trfListCompStmt others)))
+
+trfListCompStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf [Ann AST.UCompStmt (Dom r) RangeStage]
+trfListCompStmt (L l trst@(TransStmt { trS_stmts = stmts })) 
+  = (++) <$> (concat <$> local (\s -> s { contRange = mkSrcSpan (srcSpanStart (contRange s)) (srcSpanEnd (getLoc (last stmts))) }) (trfScopedSequence trfListCompStmt stmts)) 
+         <*> ((:[]) <$> extractActualStmt trst)
+-- last statement is extracted
+trfListCompStmt (unLoc -> LastStmt _ _ _) = pure []
+trfListCompStmt other = (:[]) <$> copyAnnot AST.UCompStmt (trfDoStmt other)
+  
+extractActualStmt :: TransformName n r => Stmt n (LHsExpr n) -> Trf (Ann AST.UCompStmt (Dom r) RangeStage)
+extractActualStmt = \case
+  TransStmt { trS_form = ThenForm, trS_using = using, trS_by = by } 
+    -> 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))
+  where addAnnotation by using
+          = annLocNoSema (combineSrcSpans (getLoc using) . combineSrcSpans (maybe noSrcSpan getLoc by)
+                            <$> tokenLocBack AnnThen)
+  
+getNormalStmts :: [Located (Stmt n (LHsExpr n))] -> [Located (Stmt n (LHsExpr n))]
+getNormalStmts (L _ (LastStmt body _ _) : rest) = getNormalStmts rest
+getNormalStmts (stmt : rest) = stmt : getNormalStmts rest 
+getNormalStmts [] = []
+ 
+getLastStmt :: [Located (Stmt n (LHsExpr n))] -> Located (HsExpr n)
+getLastStmt (L _ (LastStmt body _ _) : rest) = body
+getLastStmt (_ : rest) = getLastStmt rest
+

+ Language/Haskell/Tools/AST/FromGHC/TH.hs view

@@ -0,0 +1,60 @@+-- | Functions that convert the Template-Haskell-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation
+module Language.Haskell.Tools.AST.FromGHC.TH where
+
+import Control.Monad.Reader
+
+import SrcLoc as GHC
+import RdrName as GHC
+import HsTypes as GHC
+import HsExpr as GHC
+import ApiAnnotation as GHC
+import FastString as GHC
+import OccName as GHC
+import SrcLoc as GHC
+
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+import Language.Haskell.Tools.AST.FromGHC.Decls
+import Language.Haskell.Tools.AST.FromGHC.Exprs
+import Language.Haskell.Tools.AST.FromGHC.Types
+import Language.Haskell.Tools.AST.FromGHC.Patterns
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+
+import Language.Haskell.Tools.AST (Ann, Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+
+trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.UQuasiQuote (Dom r) RangeStage)
+ -- the lexer does not provide us with tokens '[', '|' and '|]'
+trfQuasiQuotation' (HsQuasiQuote id _ l str) 
+  = AST.UQuasiQuote <$> annLocNoSema (pure quoterLoc) (trfName' id)
+                   <*> annLocNoSema (pure strLoc) (pure $ AST.QQString (unpackFS str))
+  where quoterLoc = mkSrcSpan (updateCol (subtract (1 + length (occNameString $ rdrNameOcc $ rdrName id))) (srcSpanStart l)) 
+                              (updateCol (subtract 1) (srcSpanStart l))
+        strLoc = mkSrcSpan (srcSpanStart l) (updateCol (subtract 2) (srcSpanEnd l))
+
+trfSplice :: TransformName n r => Located (HsSplice n) -> Trf (Ann AST.USplice (Dom r) RangeStage)
+trfSplice = trfLocNoSema trfSplice'
+
+trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.USplice (Dom r) RangeStage)
+trfSplice' (HsTypedSplice _ expr) = AST.UParenSplice <$> trfCorrectDollar expr
+trfSplice' (HsUntypedSplice _ expr) = AST.UParenSplice <$> trfCorrectDollar expr
+
+trfCorrectDollar :: TransformName n r => Located (HsExpr n) -> Trf (Ann AST.UExpr (Dom r) RangeStage)
+trfCorrectDollar expr = 
+  do isSplice <- allTokenLoc AnnThIdSplice
+     case isSplice of [] -> trfExpr expr
+                      _  -> let newSp = updateStart (updateCol (+1)) (getLoc expr) 
+                             in case expr of L _ (HsVar (L _ varName)) -> trfExpr $ L newSp (HsVar (L newSp varName))
+                                             L _ exp                   -> trfExpr $ L newSp exp
+
+trfBracket' :: TransformName n r => HsBracket n -> Trf (AST.UBracket (Dom r) RangeStage)
+trfBracket' (ExpBr expr) = AST.UExprBracket <$> trfExpr expr
+trfBracket' (TExpBr expr) = AST.UExprBracket <$> trfExpr expr
+trfBracket' (VarBr isSingle expr) 
+  = AST.UExprBracket <$> annLoc createScopeInfo (updateStart (updateCol (if isSingle then (+1) else (+2))) <$> asks contRange) 
+      (AST.UVar <$> (annContNoSema (trfName' expr)))
+trfBracket' (PatBr pat) = AST.UPatternBracket <$> trfPattern pat
+trfBracket' (DecBrL decls) = AST.UDeclsBracket <$> trfDecls decls
+trfBracket' (DecBrG decls) = AST.UDeclsBracket <$> trfDeclsGroup decls
+trfBracket' (TypBr typ) = AST.UTypeBracket <$> trfType typ

+ Language/Haskell/Tools/AST/FromGHC/TH.hs-boot view

@@ -0,0 +1,16 @@+module Language.Haskell.Tools.AST.FromGHC.TH where
+
+import SrcLoc as GHC
+import RdrName as GHC
+import HsTypes as GHC
+import HsExpr as GHC
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+import Language.Haskell.Tools.AST.FromGHC.Names
+import Language.Haskell.Tools.AST (Ann(..), Dom, RangeStage)
+import qualified Language.Haskell.Tools.AST as AST
+
+trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.UQuasiQuote (Dom r) RangeStage)
+trfSplice :: TransformName n r => Located (HsSplice n) -> Trf (Ann AST.USplice (Dom r) RangeStage)
+trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.USplice (Dom r) RangeStage)
+trfBracket' :: TransformName n r => HsBracket n -> Trf (AST.UBracket (Dom r) RangeStage)

+ Language/Haskell/Tools/AST/FromGHC/Types.hs view

@@ -0,0 +1,120 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , ScopedTypeVariables
+           #-}
+-- | Functions that convert the type-related elements of the GHC AST to corresponding elements in the Haskell-tools AST representation
+module Language.Haskell.Tools.AST.FromGHC.Types where
+ 
+import SrcLoc as GHC
+import RdrName as GHC
+import HsTypes as GHC
+import ApiAnnotation as GHC
+import FastString as GHC
+import Type as GHC
+import TyCon as GHC
+import Outputable as GHC
+import TysWiredIn (heqTyCon)
+import Id (mkVanillaGlobal)
+
+import Control.Monad.Reader.Class
+import Control.Applicative
+import Control.Reference
+import Data.Maybe
+import Data.List (find)
+import Data.Data (Data(..), toConstr)
+
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+import Language.Haskell.Tools.AST.FromGHC.Names
+import {-# SOURCE #-} Language.Haskell.Tools.AST.FromGHC.TH
+import Language.Haskell.Tools.AST.FromGHC.Kinds
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+import Language.Haskell.Tools.AST.FromGHC.Literals
+
+import Language.Haskell.Tools.AST as AST
+
+import Debug.Trace
+
+trfType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UType (Dom r) RangeStage)
+trfType typ = do othSplices <- asks typeSplices
+                 let RealSrcSpan loce = getLoc typ
+                     contSplice = find (\sp -> case getSpliceLoc sp of (RealSrcSpan spLoc) -> spLoc `containsSpan` loce; _ -> False) othSplices
+                 case contSplice of Just sp -> let loc = pure $ getSpliceLoc sp
+                                                in typeSpliceInserted sp (annLocNoSema loc (AST.UTySplice <$> annLocNoSema loc (trfSplice' sp)))
+                                    Nothing -> trfLocNoSema trfType' typ
+
+trfType' :: TransformName n r => HsType n -> Trf (AST.UType (Dom r) RangeStage)
+trfType' = trfType'' . cleanHsType where
+  trfType'' (HsForAllTy [] typ) = trfType' (unLoc typ)
+  trfType'' (HsForAllTy bndrs typ) = AST.UTyForall <$> defineTypeVars (trfBindings bndrs) 
+                                                  <*> addToScope bndrs (trfType 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 
+    = 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
+  trfType'' (HsListTy typ) = AST.UTyList <$> trfType typ
+  trfType'' (HsPArrTy typ) = AST.UTyParArray <$> trfType typ
+  trfType'' (HsTupleTy HsBoxedOrConstraintTuple typs) = AST.UTyTuple <$> trfAnnList ", " trfType' typs
+  trfType'' (HsTupleTy HsBoxedTuple typs) = AST.UTyTuple <$> trfAnnList ", " trfType' typs
+  trfType'' (HsTupleTy HsUnboxedTuple typs) = AST.UTyUnbTuple <$> trfAnnList ", " trfType' typs
+  trfType'' (HsOpTy t1 op t2) = AST.UTyInfix <$> trfType t1 <*> trfOperator op <*> trfType t2
+  trfType'' (HsParTy typ) = AST.UTyParen <$> trfType typ
+  trfType'' (HsKindSig typ kind) = AST.UTyKinded <$> trfType typ <*> trfKind kind
+  trfType'' (HsSpliceTy splice _) = AST.UTySplice <$> annContNoSema (trfSplice' splice)
+  trfType'' (HsBangTy (HsSrcBang _ SrcUnpack _) typ) = AST.UTyUnpack <$> trfType typ
+  trfType'' (HsBangTy (HsSrcBang _ SrcNoUnpack _) typ) = AST.UTyNoUnpack <$> trfType typ
+  trfType'' (HsBangTy (HsSrcBang _ _ SrcStrict) typ) = AST.UTyBang <$> trfType typ
+  trfType'' (HsBangTy (HsSrcBang _ _ SrcLazy) typ) = AST.UTyLazy <$> trfType typ
+  trfType'' pt@(HsExplicitListTy {}) = AST.UTyPromoted <$> annContNoSema (trfPromoted' trfType' pt) 
+  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'' t = error ("Illegal type: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")")
+  
+trfBindings :: TransformName n r => [Located (HsTyVarBndr n)] -> Trf (AnnListG AST.UTyVar (Dom r) RangeStage)
+trfBindings vars = trfAnnList "\n" trfTyVar' vars
+  
+trfTyVar :: TransformName n r => Located (HsTyVarBndr n) -> Trf (Ann AST.UTyVar (Dom r) RangeStage)
+trfTyVar = trfLocNoSema trfTyVar' 
+  
+trfTyVar' :: TransformName n r => HsTyVarBndr n -> Trf (AST.UTyVar (Dom r) RangeStage)
+trfTyVar' (UserTyVar name) = AST.UTyVarDecl <$> typeVarTransform (trfName name)
+                                           <*> (nothing " " "" atTheEnd)
+trfTyVar' (KindedTyVar name kind) = AST.UTyVarDecl <$> typeVarTransform (trfName name) 
+                                                  <*> trfKindSig (Just kind)
+  
+trfCtx :: TransformName n r => Trf SrcLoc -> Located (HsContext n) -> Trf (AnnMaybeG AST.UContext (Dom r) RangeStage)
+trfCtx sp (L l []) = nothing " " "" sp
+trfCtx _ (L l [L _ (HsParTy t)]) 
+  = makeJust <$> annLocNoSema (combineSrcSpans l <$> tokenLoc AnnDarrow) 
+                              (AST.UContextMulti <$> trfAnnList ", " trfAssertion' [t])
+trfCtx _ (L l [t]) 
+  = makeJust <$> annLocNoSema (combineSrcSpans l <$> tokenLoc AnnDarrow) 
+                              (AST.UContextOne <$> trfAssertion t)
+trfCtx _ (L l ctx) = makeJust <$> annLocNoSema (combineSrcSpans l <$> tokenLoc AnnDarrow) 
+                                               (AST.UContextMulti <$> trfAnnList ", " trfAssertion' ctx) 
+  
+trfAssertion :: TransformName n r => LHsType n -> Trf (Ann AST.UAssertion (Dom r) RangeStage)
+trfAssertion = trfLocNoSema trfAssertion'
+
+trfAssertion' :: forall n r . TransformName n r => HsType n -> Trf (AST.UAssertion (Dom r) RangeStage)
+trfAssertion' (cleanHsType -> HsParTy t) 
+  = trfAssertion' (unLoc t)
+trfAssertion' (cleanHsType -> HsOpTy left op right) 
+  = AST.UInfixAssert <$> trfType left <*> trfOperator op <*> trfType right
+trfAssertion' (cleanHsType -> t) = case cleanHsType base of
+   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
+   t -> error ("Illegal trf assertion: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")")
+  where (args, sp, base) = getArgs t
+        getArgs :: HsType n -> ([LHsType n], Maybe SrcSpan, HsType n)
+        getArgs (HsAppTy (L l ft) at) = case getArgs ft of (args, sp, base) -> (args++[at], sp <|> Just l, base)
+        getArgs t = ([], Nothing, t)
+
+        typeEq :: n 
+        typeEq = nameFromId (mkVanillaGlobal (tyConName heqTyCon) (tyConKind heqTyCon))

+ Language/Haskell/Tools/AST/FromGHC/Utils.hs view

@@ -0,0 +1,368 @@+-- | Utility functions for transforming the GHC AST representation into our own.
+{-# LANGUAGE TypeSynonymInstances 
+           , FlexibleInstances
+           , LambdaCase
+           , ViewPatterns
+           , MultiParamTypeClasses
+           , FlexibleContexts
+           , AllowAmbiguousTypes
+           , TypeApplications
+           , TypeFamilies
+           #-}
+module Language.Haskell.Tools.AST.FromGHC.Utils where
+
+import ApiAnnotation
+import SrcLoc
+import GHC
+import Avail
+import HscTypes
+import BasicTypes
+import HsSyn
+import Module
+import Name
+import NameSet
+import Outputable
+import FastString
+
+import Control.Monad.Reader
+import Control.Reference hiding (element)
+import Data.Maybe
+import Data.IORef
+import Data.Function hiding ((&))
+import Data.List
+import Data.Char
+import Language.Haskell.Tools.AST as AST
+import Language.Haskell.Tools.AST.SemaInfoTypes
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+import Language.Haskell.Tools.AST.FromGHC.SourceMap
+import Debug.Trace
+
+-- | Creates a semantic information for a name
+createNameInfo :: n -> Trf (NameInfo n)
+createNameInfo name = do locals <- asks localsInScope
+                         isDefining <- asks defining
+                         return (mkNameInfo locals isDefining name)
+
+
+-- | Creates a semantic information for an ambiguous name (caused by field disambiguation for example)
+createAmbigousNameInfo :: RdrName -> SrcSpan -> Trf (NameInfo n)
+createAmbigousNameInfo name span = do locals <- asks localsInScope
+                                      isDefining <- asks defining
+                                      return (mkAmbiguousNameInfo locals isDefining name span)
+
+-- | Creates a semantic information for an implicit name
+createImplicitNameInfo :: String -> Trf (NameInfo n)
+createImplicitNameInfo name = do locals <- asks localsInScope
+                                 isDefining <- asks defining
+                                 rng <- asks contRange
+                                 return (mkImplicitNameInfo locals isDefining name rng)
+
+-- | Creates a semantic information for an implicit name
+createImplicitFldInfo :: (GHCName n, HsHasName n) => (a -> n) -> [HsRecField n a] -> Trf ImplicitFieldInfo
+createImplicitFldInfo select flds = return (mkImplicitFieldInfo (map getLabelAndExpr flds))
+  where getLabelAndExpr fld = ( head $ hsGetNames $ unLoc (getFieldOccName (hsRecFieldLbl fld))
+                              , head $ hsGetNames $ select (hsRecFieldArg fld) )
+
+-- | Adds semantic information to an impord declaration. See ImportInfo.
+createImportData :: (GHCName r, HsHasName n) => GHC.ImportDecl n -> Trf (ImportInfo r)
+createImportData (GHC.ImportDecl src name pkg isSrc isSafe isQual isImpl declAs declHiding) = 
+  do (mod,importedNames) <- getImportedNames (Module.moduleNameString $ unLoc name) (fmap (unpackFS . sl_fs) pkg)
+     names <- liftGhc $ filterM (checkImportVisible declHiding) importedNames
+     lookedUpNames <- liftGhc $ mapM (getFromNameUsing getTopLevelId) names
+     lookedUpImported <- liftGhc $ mapM (getFromNameUsing getTopLevelId) importedNames
+     return $ mkImportInfo mod (catMaybes lookedUpImported) (catMaybes lookedUpNames)
+
+-- | Get names that are imported from a given import
+getImportedNames :: String -> Maybe String -> Trf (GHC.Module, [GHC.Name])
+getImportedNames name pkg = liftGhc $ do
+  eps <- getSession >>= liftIO . readIORef . hsc_EPS
+  mod <- findModule (mkModuleName name) (fmap mkFastString pkg)
+  -- load exported names from interface file
+  let ifaceNames = concatMap availNames $ maybe [] mi_exports 
+                                        $ flip lookupModuleEnv mod 
+                                        $ eps_PIT eps
+  loadedNames <- maybe [] modInfoExports <$> getModuleInfo mod
+  return (mod, ifaceNames ++ loadedNames)
+
+-- | Check is a given name is imported from an import with given import specification.
+checkImportVisible :: (HsHasName name, GhcMonad m) => Maybe (Bool, Located [LIE name]) -> GHC.Name -> m Bool
+checkImportVisible (Just (isHiding, specs)) name
+  | isHiding  = not . or  @[] <$> mapM (`ieSpecMatches` name) (map unLoc (unLoc specs))
+  | otherwise = or @[] <$> mapM (`ieSpecMatches` name) (map unLoc (unLoc specs))
+checkImportVisible _ _ = return True
+
+ieSpecMatches :: (HsHasName name, GhcMonad m) => IE name -> GHC.Name -> m Bool
+ieSpecMatches (hsGetNames . HsSyn.ieName -> [n]) name
+  | n == name = return True
+  | isTyConName n
+  = (\case Just (ATyCon tc) -> name `elem` map getName (tyConDataCons tc)) 
+             <$> lookupName n
+ieSpecMatches _ _ = return False
+
+noSemaInfo :: src -> NodeInfo NoSemanticInfo src
+noSemaInfo = NodeInfo mkNoSemanticInfo
+
+-- | Creates a place for a missing node with a default location
+nothing :: String -> String -> Trf SrcLoc -> Trf (AnnMaybeG e (Dom n) RangeStage)
+nothing bef aft pos = annNothing . noSemaInfo . OptionalPos bef aft <$> pos 
+
+emptyList :: String -> Trf SrcLoc -> Trf (AnnListG e (Dom n) RangeStage)
+emptyList sep ann = AnnListG <$> (noSemaInfo . ListPos "" "" sep False <$> ann) <*> pure []
+
+-- | Creates a place for a list of nodes with a default place if the list is empty.
+makeList :: String -> Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnListG e (Dom n) RangeStage)
+makeList sep ann ls = AnnListG <$> (noSemaInfo . ListPos "" "" sep False <$> ann) <*> ls
+
+makeListBefore :: String -> String -> Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnListG e (Dom n) RangeStage)
+makeListBefore bef sep ann ls = do isEmpty <- null <$> ls 
+                                   AnnListG <$> (noSemaInfo . ListPos (if isEmpty then bef else "") "" sep False <$> ann) <*> ls
+
+makeListAfter :: String -> String -> Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnListG e (Dom n) RangeStage)
+makeListAfter aft sep ann ls = do isEmpty <- null <$> ls 
+                                  AnnListG <$> (noSemaInfo . ListPos "" (if isEmpty then aft else "") sep False <$> ann) <*> ls
+
+makeNonemptyList :: String -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnListG e (Dom n) RangeStage)
+makeNonemptyList sep ls = AnnListG (noSemaInfo $ ListPos "" "" sep False noSrcLoc) <$> ls
+
+-- | Creates a place for an indented list of nodes with a default place if the list is empty.
+makeIndentedList :: Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnListG e (Dom n) RangeStage)
+makeIndentedList ann ls = AnnListG <$> (noSemaInfo . ListPos  "" "" "\n" True <$> ann) <*> ls
+
+makeIndentedListNewlineBefore :: Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnListG e (Dom n) RangeStage)
+makeIndentedListNewlineBefore ann ls = do isEmpty <- null <$> ls 
+                                          AnnListG <$> (noSemaInfo . ListPos (if isEmpty then "\n" else "") "" "\n" True <$> ann) <*> ls
+
+makeIndentedListBefore :: String -> Trf SrcLoc -> Trf [Ann e (Dom n) RangeStage] -> Trf (AnnListG e (Dom n) RangeStage)
+makeIndentedListBefore bef sp ls = do isEmpty <- null <$> ls 
+                                      AnnListG <$> (noSemaInfo . ListPos (if isEmpty then bef else "") "" "\n" True <$> sp) <*> ls
+  
+makeNonemptyIndentedList :: Trf [Ann e (Dom n) RangeStage] -> Trf (AnnListG e (Dom n) RangeStage)
+makeNonemptyIndentedList ls = AnnListG (noSemaInfo $ ListPos "" "" "\n" True noSrcLoc) <$> ls
+  
+-- | Transform a located part of the AST by automatically transforming the location.
+-- Sets the source range for transforming children.
+trfLoc :: (a -> Trf (b (Dom n) RangeStage)) -> Trf (SemanticInfo (Dom n) b) -> Located a -> Trf (Ann b (Dom n) RangeStage)
+trfLoc f sema = trfLocCorrect sema pure f
+
+trfLocNoSema :: SemanticInfo (Dom n) b ~ NoSemanticInfo => (a -> Trf (b (Dom n) RangeStage)) -> Located a -> Trf (Ann b (Dom n) RangeStage)
+trfLocNoSema f = trfLoc f (pure mkNoSemanticInfo)
+
+-- | Transforms a possibly-missing node with the default location of the end of the focus.
+trfMaybe :: String -> String -> (Located a -> Trf (Ann e (Dom n) RangeStage)) -> Maybe (Located a) -> Trf (AnnMaybeG e (Dom n) RangeStage)
+trfMaybe bef aft f = trfMaybeDefault bef aft f atTheEnd
+
+-- | Transforms a possibly-missing node with a default location
+trfMaybeDefault :: String -> String -> (Located a -> Trf (Ann e (Dom n) RangeStage)) -> Trf SrcLoc -> Maybe (Located a) -> Trf (AnnMaybeG e (Dom n) RangeStage)
+trfMaybeDefault _   _   f _   (Just e) = makeJust <$> f e
+trfMaybeDefault bef aft _ loc Nothing  = nothing bef aft loc
+
+-- | Transform a located part of the AST by automatically transforming the location
+-- with correction by applying the given function. Sets the source range for transforming children.
+trfLocCorrect :: Trf (SemanticInfo (Dom n) b) -> (SrcSpan -> Trf SrcSpan) -> (a -> Trf (b (Dom n) RangeStage)) -> Located a -> Trf (Ann b (Dom n) RangeStage)
+trfLocCorrect sema locF f (L l e) = annLoc sema (locF l) (f e)
+
+-- | Transform a located part of the AST by automatically transforming the location.
+-- Sets the source range for transforming children.
+trfMaybeLoc :: (a -> Trf (Maybe (b (Dom n) RangeStage))) -> SemanticInfo (Dom n) b -> Located a -> Trf (Maybe (Ann b (Dom n) RangeStage))
+trfMaybeLoc f sema (L l e) = do fmap (Ann (NodeInfo sema (NodeSpan l))) <$> local (\s -> s { contRange = l }) (f e)
+
+trfMaybeLocNoSema :: SemanticInfo (Dom n) b ~ NoSemanticInfo => (a -> Trf (Maybe (b (Dom n) RangeStage))) -> Located a -> Trf (Maybe (Ann b (Dom n) RangeStage))
+trfMaybeLocNoSema f = trfMaybeLoc f mkNoSemanticInfo
+
+-- | Creates a place for a list of nodes with the default place at the end of the focus if the list is empty.
+trfAnnList :: SemanticInfo (Dom n) b ~ NoSemanticInfo => String -> (a -> Trf (b (Dom n) RangeStage)) -> [Located a] -> Trf (AnnListG b (Dom n) RangeStage)
+trfAnnList sep _ [] = makeList sep atTheEnd (pure [])
+trfAnnList sep f ls = makeList sep (pure $ noSrcLoc) (mapM (trfLoc f (pure mkNoSemanticInfo)) ls)
+
+trfAnnList' :: String -> (Located a -> Trf (Ann b (Dom n) RangeStage)) -> [Located a] -> Trf (AnnListG b (Dom n) RangeStage)
+trfAnnList' sep _ [] = makeList sep atTheEnd (pure [])
+trfAnnList' sep f ls = makeList sep (pure $ noSrcLoc) (mapM f ls)
+
+
+-- | Creates a place for a list of nodes that cannot be empty.
+nonemptyAnnList :: [Ann e (Dom n) RangeStage] -> AnnListG e (Dom n) RangeStage
+nonemptyAnnList = AnnListG (noSemaInfo $ ListPos "" "" "" False noSrcLoc)
+
+-- | Creates an optional node from an existing element
+makeJust :: Ann e (Dom n) RangeStage -> AnnMaybeG e (Dom n) RangeStage
+makeJust e = AnnMaybeG (noSemaInfo $ OptionalPos "" "" noSrcLoc) (Just e)
+
+-- | Annotates a node with the given location and focuses on the given source span.
+annLoc :: Trf (SemanticInfo (Dom n) b) -> Trf SrcSpan -> Trf (b (Dom n) RangeStage) -> Trf (Ann b (Dom n) RangeStage)
+annLoc semam locm nodem = do loc <- locm
+                             node <- focusOn loc nodem
+                             sema <- semam
+                             return (Ann (NodeInfo sema (NodeSpan loc)) node)
+
+annLocNoSema :: SemanticInfo (Dom n) b ~ NoSemanticInfo => Trf SrcSpan -> Trf (b (Dom n) RangeStage) -> Trf (Ann b (Dom n) RangeStage)
+annLocNoSema = annLoc (pure mkNoSemanticInfo)
+
+-- * Focus manipulation
+
+focusOn :: SrcSpan -> Trf a -> Trf a
+focusOn sp = local (\s -> s { contRange = sp })
+
+updateFocus :: (SrcSpan -> Trf SrcSpan) -> Trf a -> Trf a
+updateFocus f trf = do newSpan <- f =<< asks contRange
+                       focusOn newSpan trf
+
+-- | 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
+
+-- | Focuses the transformation to go between tokens if they are present
+betweenIfPresent :: AnnKeywordId -> AnnKeywordId -> Trf a -> Trf a
+betweenIfPresent firstTok lastTok = focusAfterIfPresent firstTok . focusBeforeIfPresent lastTok
+
+-- | Focuses the transformation to be performed after the given token. The token must be found inside the current range.
+focusAfter :: AnnKeywordId -> Trf a -> Trf a
+focusAfter firstTok trf
+  = do firstToken <- tokenLoc firstTok
+       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
+
+focusAfterIfPresent :: AnnKeywordId -> Trf a -> Trf a
+focusAfterIfPresent firstTok trf
+  = do firstToken <- tokenLoc firstTok
+       if (isGoodSrcSpan firstToken)
+          then local (\s -> s { contRange = mkSrcSpan (srcSpanEnd firstToken) (srcSpanEnd (contRange s))}) trf
+          else trf
+
+-- | Focuses the transformation to be performed before the given token. The token must be found inside the current range.
+focusBefore :: AnnKeywordId -> Trf a -> Trf a
+focusBefore lastTok trf
+  = do lastToken <- tokenLocBack lastTok
+       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
+
+focusBeforeIfPresent :: AnnKeywordId -> Trf a -> Trf a
+focusBeforeIfPresent lastTok trf
+  = do lastToken <- tokenLocBack lastTok
+       if (isGoodSrcSpan lastToken)
+          then local (\s -> s { contRange = mkSrcSpan (srcSpanStart (contRange s)) (srcSpanStart lastToken)}) trf
+          else trf
+
+-- | Gets the position before the given token
+before :: AnnKeywordId -> Trf SrcLoc
+before tok = srcSpanStart <$> tokenLoc tok
+               
+-- | Gets the position after the given token
+after :: AnnKeywordId -> Trf SrcLoc
+after tok = srcSpanEnd <$> tokenLoc tok
+
+-- | The element should span from the given token to the end of focus
+annFrom :: AnnKeywordId -> Trf (SemanticInfo (Dom n) e) -> Trf (e (Dom n) RangeStage) -> Trf (Ann e (Dom n) RangeStage)
+annFrom kw sema = annLoc sema (combineSrcSpans <$> tokenLoc kw <*> asks (srcLocSpan . srcSpanEnd . contRange))
+
+annFromNoSema :: SemanticInfo (Dom n) e ~ NoSemanticInfo => AnnKeywordId -> Trf (e (Dom n) RangeStage) -> Trf (Ann e (Dom n) RangeStage)
+annFromNoSema kw = annFrom kw (pure mkNoSemanticInfo)
+
+-- | Gets the position at the beginning of the focus       
+atTheStart :: Trf SrcLoc
+atTheStart = asks (srcSpanStart . contRange)
+            
+-- | Gets the position at the end of the focus      
+atTheEnd :: Trf SrcLoc
+atTheEnd = asks (srcSpanEnd . contRange)
+                 
+-- | Searches for a token inside the focus and retrieves its location
+tokenLoc :: AnnKeywordId -> Trf SrcSpan
+tokenLoc keyw = fromMaybe noSrcSpan <$> (getKeywordInside keyw <$> asks contRange <*> asks srcMap)
+
+allTokenLoc :: AnnKeywordId -> Trf [SrcSpan]
+allTokenLoc keyw = getKeywordsInside keyw <$> asks contRange <*> asks srcMap
+
+-- | Searches for a token backward inside the focus and retrieves its location
+tokenLocBack :: AnnKeywordId -> Trf SrcSpan
+tokenLocBack keyw = fromMaybe noSrcSpan <$> (getKeywordInsideBack keyw <$> asks contRange <*> asks srcMap)
+
+tokenBefore :: SrcLoc -> AnnKeywordId -> Trf SrcSpan
+tokenBefore loc keyw 
+  = fromMaybe noSrcSpan <$> (getKeywordInsideBack keyw <$> (mkSrcSpan <$> (asks (srcSpanStart . contRange)) <*> pure loc) <*> asks srcMap)
+
+allTokensAfter :: SrcLoc -> Trf [(SrcSpan, AnnKeywordId)]
+allTokensAfter loc = getTokensAfter loc <$> asks srcMap
+
+-- | 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' [] r = pure noSrcSpan
+        
+-- | Searches for a token and retrieves its location anywhere
+uniqueTokenAnywhere :: AnnKeywordId -> Trf SrcSpan
+uniqueTokenAnywhere keyw = fromMaybe noSrcSpan <$> (getKeywordAnywhere keyw <$> asks srcMap)
+        
+-- | Annotates the given element with the current focus as a location.
+annCont :: Trf (SemanticInfo (Dom n) e) -> Trf (e (Dom n) RangeStage) -> Trf (Ann e (Dom n) RangeStage)
+annCont sema = annLoc sema (asks contRange)
+
+annContNoSema :: SemanticInfo (Dom n) e ~ NoSemanticInfo => Trf (e (Dom n) RangeStage) -> Trf (Ann e (Dom n) RangeStage)
+annContNoSema = annCont (pure mkNoSemanticInfo)
+
+-- | Annotates the element with the same annotation that is on the other element
+copyAnnot :: SemanticInfo (Dom n) a ~ SemanticInfo (Dom n) b 
+               => (Ann a (Dom n) RangeStage -> b (Dom n) RangeStage) -> Trf (Ann a (Dom n) RangeStage) -> Trf (Ann b (Dom n) RangeStage)
+copyAnnot f at = (\(Ann i a) -> Ann i (f (Ann i a))) <$> at
+
+-- | Combine source spans into one that contains them all
+foldLocs :: [SrcSpan] -> SrcSpan
+foldLocs = foldl combineSrcSpans noSrcSpan
+
+-- | The location after the given string
+advanceStr :: String -> SrcLoc -> SrcLoc
+advanceStr str (RealSrcLoc l) = RealSrcLoc $ foldl advanceSrcLoc l str
+advanceStr _ l = l
+
+-- | Update column information in a source location
+updateCol :: (Int -> Int) -> SrcLoc -> SrcLoc
+updateCol f loc@(UnhelpfulLoc _) = loc
+updateCol f (RealSrcLoc loc) = mkSrcLoc (srcLocFile loc) (srcLocLine loc) (f $ srcLocCol loc)
+
+-- | Update the start of the src span
+updateStart :: (SrcLoc -> SrcLoc) -> SrcSpan -> SrcSpan
+updateStart f sp = mkSrcSpan (f (srcSpanStart sp)) (srcSpanEnd sp)
+
+-- | Update the end of the src span
+updateEnd :: (SrcLoc -> SrcLoc) -> SrcSpan -> SrcSpan
+updateEnd f sp = mkSrcSpan (srcSpanStart sp) (f (srcSpanEnd sp))
+
+-- | Combine source spans of elements into one that contains them all
+collectLocs :: [Located e] -> SrcSpan
+collectLocs = foldLocs . map getLoc
+
+-- | Rearrange definitions to appear in the order they are defined in the source file.
+orderDefs :: [Ann e (Dom n) RangeStage] -> [Ann e (Dom n) RangeStage]
+orderDefs = sortBy (compare `on` AST.ordSrcSpan . (^. AST.annotation & AST.sourceInfo & AST.nodeSpan))
+
+-- | Orders a list of elements to the order they are defined in the source file.
+orderAnnList :: AnnListG e (Dom n) RangeStage -> AnnListG e (Dom n) RangeStage
+orderAnnList (AnnListG a ls) = AnnListG a (orderDefs ls)
+
+
+-- | Transform a list of definitions where the defined names are in scope for subsequent definitions
+trfScopedSequence :: HsHasName d => (d -> Trf e) -> [d] -> Trf [e]
+trfScopedSequence f (def:rest) = (:) <$> f def <*> addToScope def (trfScopedSequence f rest)
+trfScopedSequence f [] = pure []
+
+-- | 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
+  where splitLocated' :: String -> RealSrcLoc -> Maybe (RealSrcLoc, String) -> [Located String]
+        splitLocated' (c:rest) currLoc (Just (startLoc, str)) | isSpace 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 (Just (startLoc, str)) = splitLocated' rest (advanceSrcLoc currLoc c) (Just (startLoc, c:str))
+        splitLocated' (c:rest) currLoc Nothing = splitLocated' rest (advanceSrcLoc currLoc c) (Just (currLoc, [c]))
+        splitLocated' [] currLoc (Just (startLoc, str)) = [L (RealSrcSpan $ mkRealSrcSpan startLoc currLoc) (reverse str)]
+        splitLocated' [] currLoc Nothing = []
+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ haskell-tools-backend-ghc.cabal view

@@ -0,0 +1,45 @@+name:                haskell-tools-backend-ghc
+version:             0.3.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
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Language.Haskell.Tools.AST.FromGHC   
+                     , Language.Haskell.Tools.AST.FromGHC.Modules
+                     , Language.Haskell.Tools.AST.FromGHC.TH
+                     , Language.Haskell.Tools.AST.FromGHC.Decls
+                     , Language.Haskell.Tools.AST.FromGHC.Binds
+                     , Language.Haskell.Tools.AST.FromGHC.Exprs
+                     , Language.Haskell.Tools.AST.FromGHC.Stmts
+                     , Language.Haskell.Tools.AST.FromGHC.Patterns
+                     , Language.Haskell.Tools.AST.FromGHC.Types
+                     , Language.Haskell.Tools.AST.FromGHC.Kinds
+                     , Language.Haskell.Tools.AST.FromGHC.Literals
+                     , Language.Haskell.Tools.AST.FromGHC.Names
+                     , Language.Haskell.Tools.AST.FromGHC.GHCUtils                  
+  other-modules:       Language.Haskell.Tools.AST.FromGHC.Monad
+                     , Language.Haskell.Tools.AST.FromGHC.Utils
+                     , Language.Haskell.Tools.AST.FromGHC.SourceMap
+                     , Language.Haskell.Tools.AST.FromGHC.AddTypeInfo
+
+  build-depends:       base              >= 4.9  && < 4.10
+                     , transformers      >= 0.5  && < 0.6
+                     , references        >= 0.3  && < 0.4
+                     , bytestring        >= 0.10 && < 0.11
+                     , safe              >= 0.3  && < 0.4
+                     , uniplate          >= 1.6  && < 1.7
+                     , 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.3  && < 0.4
+  default-language:    Haskell2010