haskell-tools-ast-fromghc (empty) → 0.1.2.0

raw patch · 22 files changed

+2390/−0 lines, 22 filesdep +basedep +bytestringdep +containerssetup-changed

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

Files

LICENSE +29/−0
Language/Haskell/Tools/AST/FromGHC.hs +14/−0
Language/Haskell/Tools/AST/FromGHC/Base.hs +183/−0
Language/Haskell/Tools/AST/FromGHC/Binds.hs +154/−0
Language/Haskell/Tools/AST/FromGHC/Binds.hs-boot +17/−0
Language/Haskell/Tools/AST/FromGHC/Decls.hs +424/−0
Language/Haskell/Tools/AST/FromGHC/Exprs.hs +210/−0
Language/Haskell/Tools/AST/FromGHC/Exprs.hs-boot +16/−0
Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs +187/−0
Language/Haskell/Tools/AST/FromGHC/Kinds.hs +62/−0
Language/Haskell/Tools/AST/FromGHC/Literals.hs +36/−0
Language/Haskell/Tools/AST/FromGHC/Modules.hs +228/−0
Language/Haskell/Tools/AST/FromGHC/Monad.hs +80/−0
Language/Haskell/Tools/AST/FromGHC/Patterns.hs +70/−0
Language/Haskell/Tools/AST/FromGHC/SourceMap.hs +44/−0
Language/Haskell/Tools/AST/FromGHC/Stmts.hs +80/−0
Language/Haskell/Tools/AST/FromGHC/TH.hs +42/−0
Language/Haskell/Tools/AST/FromGHC/TH.hs-boot +15/−0
Language/Haskell/Tools/AST/FromGHC/Types.hs +111/−0
Language/Haskell/Tools/AST/FromGHC/Utils.hs +342/−0
Setup.hs +2/−0
haskell-tools-ast-fromghc.cabal +44/−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,14 @@+-- | 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 
+  ( module Language.Haskell.Tools.AST.FromGHC.Modules
+  , module Language.Haskell.Tools.AST.FromGHC.Monad
+  , module Language.Haskell.Tools.AST.FromGHC.Base
+  , module Language.Haskell.Tools.AST.FromGHC.Utils
+  ) where
+
+import Language.Haskell.Tools.AST.FromGHC.Modules
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Base
+import Language.Haskell.Tools.AST.FromGHC.Utils

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

@@ -0,0 +1,183 @@+{-# LANGUAGE LambdaCase
+           , TupleSections
+           , TypeFamilies
+           , FlexibleInstances
+           , FlexibleContexts
+           , TypeSynonymInstances
+           , ScopedTypeVariables
+           , MultiParamTypeClasses
+           , UndecidableInstances
+           , AllowAmbiguousTypes
+           , TypeApplications
+           #-}
+module Language.Haskell.Tools.AST.FromGHC.Base 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(..), AnnList(..), AnnMaybe(..), SemanticInfo(..), 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 name res => Located name -> Trf (Ann AST.Operator res)
+trfOperator = trfLoc trfOperator'
+
+trfOperator' :: TransformName name res => name -> Trf (AST.Operator res)
+trfOperator' n
+  | isSymOcc (occName n) = AST.NormalOp <$> (addNameInfo n =<< annCont (trfSimpleName' n))
+  | otherwise = AST.BacktickOp <$> (addNameInfo n =<< annLoc loc (trfSimpleName' n))
+     where loc = mkSrcSpan <$> (updateCol (+1) <$> atTheStart) <*> (updateCol (subtract 1) <$> atTheEnd)
+
+trfName :: TransformName name res => Located name -> Trf (Ann AST.Name res)
+trfName = trfLoc trfName'
+
+trfName' :: TransformName name res => name -> Trf (AST.Name res)
+trfName' n
+  | isSymOcc (occName n) = AST.ParenName <$> (addNameInfo n =<< annLoc loc (trfSimpleName' n))
+  | otherwise = AST.NormalName <$> (addNameInfo n =<< annCont (trfSimpleName' n))
+     where loc = mkSrcSpan <$> (updateCol (+1) <$> atTheStart) <*> (updateCol (subtract 1) <$> atTheEnd)
+
+trfAmbiguousFieldName :: TransformName n res => Located (AmbiguousFieldOcc n) -> Trf (Ann AST.Name res)
+trfAmbiguousFieldName all@(L l af) = trfAmbiguousFieldName' l af
+
+trfAmbiguousFieldName' :: forall n res . (TransformName n res) => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.Name res)
+trfAmbiguousFieldName' l (Unambiguous (L _ rdr) pr) = annLoc (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
+       annLoc (pure l) 
+         $ AST.NormalName 
+         <$> (annotation .- addSemanticInfo (AmbiguousNameInfo locals isDefining rdr l :: SemanticInfo n)) 
+         <$> (annLoc (pure l) $ AST.nameFromList <$> trfNameStr (rdrNameStr rdr))
+
+class (DataId n, Eq n, GHCName n) => TransformableName n where
+  correctNameString :: n -> Trf String
+
+instance TransformableName RdrName where
+  correctNameString = pure . rdrNameStr
+
+instance TransformableName GHC.Name where
+  correctNameString n = getOriginalName (rdrName n)
+
+
+-- | This class allows us to use the same transformation code for multiple variants of the GHC AST.
+-- GHC Name annotated with 'name' can be transformed to our representation with semantic annotations of 'res'.
+class (RangeAnnot res, SemanticAnnot res name, SemanticAnnot res GHC.Name, TransformableName name, HsHasName name) 
+        => TransformName name res where
+instance TransformName RdrName AST.RangeInfo where
+instance (RangeAnnot r, SemanticAnnot r GHC.Name) => TransformName GHC.Name r where
+
+addNameInfo :: TransformName n r => n -> Ann AST.SimpleName r -> Trf (Ann AST.SimpleName r)
+addNameInfo name ast = do locals <- asks localsInScope
+                          isDefining <- asks defining
+                          return (annotation .- addSemanticInfo (NameInfo locals isDefining name) $ ast)
+
+trfSimpleName :: TransformName name res => Located name -> Trf (Ann AST.SimpleName res)
+trfSimpleName name@(L l n) = addNameInfo n =<< annLoc (pure l) (trfSimpleName' n)
+
+trfSimpleName' :: TransformName name res => name -> Trf (AST.SimpleName res)
+trfSimpleName' n = AST.nameFromList <$> (trfNameStr =<< correctNameString n)
+
+-- | Creates a qualified name from a name string
+trfNameStr :: RangeAnnot a => String -> Trf (AnnList AST.UnqualName a)
+trfNameStr str = (\loc -> AnnList (toListAnnot "" "" "." loc) $ trfNameStr' str loc) <$> atTheStart
+
+trfNameStr' :: RangeAnnot a => String -> SrcLoc -> [Ann AST.UnqualName a]
+trfNameStr' str srcLoc = fst $
+  foldl (\(r,loc) np -> let nextLoc = advanceAllSrcLoc loc np
+                         in ( r ++ [Ann (toNodeAnnot $ mkSrcSpan loc nextLoc) (AST.UnqualName 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
+  
+trfModuleName :: RangeAnnot a => Located ModuleName -> Trf (Ann AST.SimpleName a)
+trfModuleName = trfLoc trfModuleName'
+
+trfModuleName' :: RangeAnnot a => ModuleName -> Trf (AST.SimpleName a)
+trfModuleName' = (AST.nameFromList <$>) . trfNameStr . moduleNameString
+
+trfFastString :: RangeAnnot a => Located FastString -> Trf (Ann AST.StringNode a)
+trfFastString = trfLoc $ pure . AST.StringNode . unpackFS
+  
+trfDataKeyword :: RangeAnnot a => NewOrData -> Trf (Ann AST.DataOrNewtypeKeyword a)
+trfDataKeyword NewType = annLoc (tokenLoc AnnNewtype) (pure AST.NewtypeKeyword)
+trfDataKeyword DataType = annLoc (tokenLoc AnnData) (pure AST.DataKeyword)
+     
+trfCallConv :: RangeAnnot a => Located CCallConv -> Trf (Ann AST.CallConv a)
+trfCallConv = trfLoc trfCallConv'
+   
+trfCallConv' :: RangeAnnot a => CCallConv -> Trf (AST.CallConv a)
+trfCallConv' CCallConv = pure AST.CCall
+trfCallConv' CApiConv = pure AST.CApi
+trfCallConv' StdCallConv = pure AST.StdCall
+-- trfCallConv' PrimCallConv = 
+trfCallConv' JavaScriptCallConv = pure AST.JavaScript
+
+trfSafety :: RangeAnnot a => SrcSpan -> Located Safety -> Trf (AnnMaybe AST.Safety a)
+trfSafety ccLoc lsaf@(L l _) | isGoodSrcSpan l 
+  = makeJust <$> trfLoc (pure . \case
+      PlaySafe -> AST.Safe
+      PlayInterruptible -> AST.Interruptible
+      PlayRisky -> AST.Unsafe) lsaf
+  | otherwise = nothing " " "" (pure $ srcSpanEnd ccLoc)
+
+trfOverlap :: RangeAnnot a => Located OverlapMode -> Trf (Ann AST.OverlapPragma a)
+trfOverlap = trfLoc $ pure . \case
+  NoOverlap _ -> AST.DisableOverlap
+  Overlappable _ -> AST.Overlappable
+  Overlapping _ -> AST.Overlapping
+  Overlaps _ -> AST.Overlaps
+  Incoherent _ -> AST.IncoherentOverlap
+
+trfRole :: RangeAnnot a => Located (Maybe Role) -> Trf (Ann AST.Role a)
+trfRole = trfLoc $ \case Just Nominal -> pure AST.Nominal
+                         Just Representational -> pure AST.Representational
+                         Just GHC.Phantom -> pure AST.Phantom
+         
+trfPhase :: RangeAnnot a => Trf SrcLoc -> Activation -> Trf (AnnMaybe AST.PhaseControl a)
+trfPhase l AlwaysActive = nothing "" " " l
+trfPhase _ (ActiveAfter _ pn) = makeJust <$> annLoc (combineSrcSpans <$> tokenLoc AnnOpenS <*> tokenLoc AnnCloseS) 
+                                                    (AST.PhaseControl <$> nothing "" "" (before AnnCloseS) <*> trfPhaseNum pn)
+trfPhase _ (ActiveBefore _ pn) = makeJust <$> annLoc (combineSrcSpans <$> tokenLoc AnnOpenS <*> tokenLoc AnnCloseS)
+                                                     (AST.PhaseControl <$> (makeJust <$> annLoc (tokenLoc AnnTilde) (pure AST.PhaseInvert)) <*> trfPhaseNum pn)
+
+trfPhaseNum :: RangeAnnot a => PhaseNum -> Trf (Ann AST.PhaseNumber a)
+trfPhaseNum i = annLoc (tokenLoc AnnVal) $ pure (AST.PhaseNumber $ fromIntegral i)

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

@@ -0,0 +1,154 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           #-}
+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.Base
+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(..), AnnMaybe(..), AnnList(..))
+import qualified Language.Haskell.Tools.AST as AST
+
+trfBind :: TransformName n r => Located (HsBind n) -> Trf (Ann AST.ValueBind r)
+trfBind = trfLoc trfBind'
+  
+trfBind' :: TransformName n r => HsBind n -> Trf (AST.ValueBind r)
+-- 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.SimpleBind <$> copyAnnot AST.VarPat (define $ trfName id)
+                   <*> addToScope locals (annLoc (combineSrcSpans (getLoc expr) <$> tokenLoc AnnEqual) (AST.UnguardedRhs <$> trfExpr expr))
+                   <*> addToScope locals (trfWhereLocalBinds locals)
+trfBind' (FunBind id (MG (unLoc -> matches) _ _ _) _ _ _) = AST.FunBind <$> makeNonemptyIndentedList (mapM (trfMatch (unLoc id)) matches)
+trfBind' (PatBind pat (GRHSs rhs (unLoc -> locals)) _ _ _) = AST.SimpleBind <$> 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 "Pattern synonym bindings should be recognized on the declaration level"
+
+trfMatch :: TransformName n r => n -> Located (Match n (LHsExpr n)) -> Trf (Ann AST.Match r)
+trfMatch id = trfLoc (trfMatch' id)
+
+trfMatch' :: TransformName n r => n -> Match n (LHsExpr n) -> Trf (AST.Match r)
+trfMatch' name (Match funid pats typ (GRHSs rhss (unLoc -> locBinds)))
+  -- TODO: add the optional typ to pats
+  = AST.Match <$> trfMatchLhs name funid pats
+              <*> addToScope pats (trfRhss rhss)
+              <*> addToScope pats (trfWhereLocalBinds locBinds)
+
+trfMatchLhs :: TransformName n r => n -> MatchFixity n -> [LPat n] -> Trf (Ann AST.MatchLhs r)
+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
+       annLoc (mkSrcSpan <$> atTheStart <*> (pure closeLoc)) $
+         case (args, isInfix) of 
+            (left:right:rest, True) -> AST.InfixLhs left <$> define (trfOperator n) <*> pure right <*> makeList " " (pure closeLoc) (pure rest)
+            _                       -> AST.NormalLhs <$> define (trfName n) <*> makeList " " (pure closeLoc) (pure args)
+
+trfRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.Rhs r)
+-- the original location on the GRHS misleadingly contains the local bindings
+trfRhss [unLoc -> GRHS [] body] = annLoc (combineSrcSpans (getLoc body) <$> tokenBefore (srcSpanStart $ getLoc body) AnnEqual) 
+                                         (AST.UnguardedRhs <$> trfExpr body)
+trfRhss rhss = annLoc (pure $ collectLocs rhss) 
+                      (AST.GuardedRhss . nonemptyAnnList <$> mapM trfGuardedRhs rhss)
+                      
+trfGuardedRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.GuardedRhs r)
+trfGuardedRhs = trfLoc $ \(GRHS guards body) 
+  -> AST.GuardedRhs . nonemptyAnnList <$> trfScopedSequence trfRhsGuard guards <*> addToScope guards (trfExpr body)
+  
+trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.RhsGuard r)
+trfRhsGuard = trfLoc trfRhsGuard'
+  
+trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.RhsGuard r)
+trfRhsGuard' (BindStmt pat body _ _ _) = AST.GuardBind <$> trfPattern pat <*> trfExpr body
+trfRhsGuard' (BodyStmt body _ _ _) = AST.GuardCheck <$> trfExpr body
+trfRhsGuard' (LetStmt (unLoc -> binds)) = AST.GuardLet <$> trfLocalBinds binds
+  
+trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybe AST.LocalBinds r)
+trfWhereLocalBinds EmptyLocalBinds = nothing "" "" atTheEnd
+trfWhereLocalBinds binds
+  = makeJust <$> annLoc (combineSrcSpans (getBindLocs binds) <$> tokenLoc AnnWhere) (AST.LocalBinds <$> 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
+  
+trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnList AST.LocalBind r)
+trfLocalBinds (HsValBinds (ValBindsIn binds sigs)) 
+  = makeIndentedList (after AnnWhere)
+      (orderDefs <$> ((++) <$> mapM (copyAnnot AST.LocalValBind . trfBind) (bagToList binds) 
+                           <*> mapM trfLocalSig sigs))
+trfLocalBinds (HsValBinds (ValBindsOut binds sigs)) 
+  = makeIndentedList (after AnnWhere)
+      (orderDefs <$> ((++) <$> (concat <$> mapM (mapM (copyAnnot AST.LocalValBind . trfBind) . bagToList . snd) binds)
+                           <*> mapM trfLocalSig sigs))
+             
+trfLocalSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.LocalBind r)
+trfLocalSig = trfLoc $ \case
+  ts@(TypeSig {}) -> AST.LocalSignature <$> annCont (trfTypeSig' ts)
+  (FixSig fs) -> AST.LocalFixity <$> annCont (trfFixitySig fs)
+  
+trfTypeSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.TypeSignature r)
+trfTypeSig = trfLoc trfTypeSig'
+
+trfTypeSig' :: TransformName n r => Sig n -> Trf (AST.TypeSignature r)
+trfTypeSig' (TypeSig names typ) 
+  = defineTypeVars $ AST.TypeSignature <$> makeNonemptyList ", " (mapM trfName names) <*> trfType (hswc_body $ hsib_body typ)
+  
+trfFixitySig :: TransformName n r => FixitySig n -> Trf (AST.FixitySignature r)
+trfFixitySig (FixitySig names (Fixity _ prec dir)) 
+  = AST.FixitySignature <$> transformDir dir
+                        <*> annLoc (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 = annLoc (srcLocSpan . srcSpanEnd <$> tokenLoc AnnInfix) (pure AST.AssocNone)
+        
+        directionChar = annLoc ((\l -> mkSrcSpan (updateCol (subtract 1) l) l) . srcSpanEnd <$> tokenLoc AnnInfix)
+   
+trfRewriteRule :: TransformName n r => Located (RuleDecl n) -> Trf (Ann AST.Rule r)
+trfRewriteRule = trfLoc $ \(HsRule (L nameLoc (_, ruleName)) act bndrs left _ right _) ->
+  AST.Rule <$> 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.TyVar r)
+trfRuleBndr = trfLoc $ \case (RuleBndr n) -> AST.TyVarDecl <$> trfName n <*> nothing " " "" atTheEnd
+                             (RuleBndrSig n k) -> AST.TyVarDecl <$> trfName n <*> (makeJust <$> (trfKindSig' (hswc_body $ hsib_body k)))
+
+trfMinimalFormula :: TransformName n r => Located (BooleanFormula (Located n)) -> Trf (Ann AST.MinimalFormula r)
+trfMinimalFormula = trfLoc trfMinimalFormula'
+
+trfMinimalFormula' :: TransformName n r => BooleanFormula (Located n) -> Trf (AST.MinimalFormula r)
+trfMinimalFormula' (Var name) = AST.MinimalName <$> trfName name
+trfMinimalFormula' (And formulas) = AST.MinimalAnd <$> trfAnnList " & " trfMinimalFormula' formulas
+trfMinimalFormula' (Or formulas) = AST.MinimalOr <$> trfAnnList " | " trfMinimalFormula' formulas
+trfMinimalFormula' (Parens formula) = AST.MinimalParen <$> trfMinimalFormula formula
+

+ 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.Base
+import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..))
+import qualified Language.Haskell.Tools.AST as AST
+
+trfLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnList AST.LocalBind r)
+trfWhereLocalBinds :: TransformName n r => HsLocalBinds n -> Trf (AnnMaybe AST.LocalBinds r)
+trfRhsGuard :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.RhsGuard r)
+trfRhsGuard' :: TransformName n r => Stmt n (LHsExpr n) -> Trf (AST.RhsGuard r)

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

@@ -0,0 +1,424 @@+{-# LANGUAGE LambdaCase 
+           , ViewPatterns
+           , ScopedTypeVariables
+           #-}
+module Language.Haskell.Tools.AST.FromGHC.Decls where
+
+import RdrName 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 Control.Monad.Reader
+import Control.Reference
+import Data.Maybe
+import Data.Data (toConstr)
+import Data.Generics.Uniplate.Data
+
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+import Language.Haskell.Tools.AST.FromGHC.Base
+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(..), AnnMaybe(..), AnnList(..), RangeWithName, getRange)
+import qualified Language.Haskell.Tools.AST as AST
+
+import Debug.Trace
+
+trfDecls :: TransformName n r => [LHsDecl n] -> Trf (AnnList AST.Decl r)
+-- TODO: filter documentation comments
+trfDecls decls = addToScope decls $ makeIndentedListNewlineBefore atTheEnd (mapM trfDecl decls)
+
+trfDeclsGroup :: forall n r . TransformName n r => HsGroup n -> Trf (AnnList AST.Decl r)
+trfDeclsGroup (HsGroup vals splices tycls insts derivs fixities defaults foreigns warns anns rules vects docs) 
+  = addAllToScope $ makeIndentedListNewlineBefore atTheEnd (fmap (orderDefs . concat) $ sequence $
+      [ trfBindOrSig vals
+      , concat <$> mapM (mapM (trfDecl . (fmap TyClD)) . group_tyclds) tycls
+      , mapM (trfDecl . (fmap SpliceD)) splices
+      , mapM (trfDecl . (fmap InstD)) insts
+      , mapM (trfDecl . (fmap DerivD)) derivs
+      , mapM (trfDecl . (fmap (SigD . FixSig))) (mergeFixityDefs fixities)
+      , mapM (trfDecl . (fmap DefD)) defaults
+      , mapM (trfDecl . (fmap ForD)) foreigns
+      , mapM (trfDecl . (fmap WarningD)) warns
+      , mapM (trfDecl . (fmap AnnD)) anns
+      , mapM (trfDecl . (fmap RuleD)) rules
+      , mapM (trfDecl . (fmap VectD)) vects
+      -- , mapM (trfDecl . (fmap DocD)) docs
+      ])
+  where trfBindOrSig :: HsValBinds n -> Trf [Ann AST.Decl r]
+        trfBindOrSig (getBindsAndSigs -> (sigs, binds))
+          = (++) <$> mapM (trfLoc trfVal) (bagToList binds)
+                 <*> mapM (trfLoc trfSig) sigs
+        addAllToScope = addToCurrentScope vals . addToCurrentScope tycls . addToCurrentScope foreigns
+           
+           
+trfDecl :: TransformName n r => Located (HsDecl n) -> Trf (Ann AST.Decl r)
+trfDecl = trfLoc $ \case
+  TyClD (FamDecl (FamilyDecl (ClosedTypeFamily typeEqs) name tyVars kindSig _)) 
+    -> AST.ClosedTypeFamilyDecl <$> focusAfter AnnType (createDeclHead name tyVars) 
+                                <*> trfFamilyKind kindSig 
+                                <*> trfTypeEqs typeEqs
+  TyClD (FamDecl fd) -> AST.TypeFamilyDecl <$> annCont (trfTypeFam' fd)
+  TyClD (SynDecl name vars rhs _) 
+    -> AST.TypeDecl <$> 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.ClassDecl <$> 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.InstDecl <$> trfMaybeDefault " " "" trfOverlap (after AnnInstance) overlap 
+                    <*> trfInstanceRule (hsib_body typ)
+                    <*> trfInstBody binds sigs typefam datafam
+  InstD (DataFamInstD (DataFamInstDecl con pats (HsDataDefn nd _ _ _ cons derivs) _))
+    -> AST.DataInstDecl <$> 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.TypeInstDecl <$> between AnnInstance AnnEqual (makeInstanceRuleTyVars con pats) <*> trfType rhs
+  ValD bind -> trfVal bind
+  SigD sig -> trfSig sig
+  DerivD (DerivDecl t overlap) -> AST.DerivDecl <$> trfMaybe "" "" trfOverlap overlap <*> trfInstanceRule (hsib_body t)
+  -- TODO: INLINE, SPECIALIZE, MINIMAL, VECTORISE pragmas, Warnings, Annotations, rewrite rules, role annotations
+  RuleD (HsRules _ rules) -> AST.PragmaDecl <$> annCont (AST.RulePragma <$> makeIndentedList (before AnnClose) (mapM trfRewriteRule rules))
+  RoleAnnotD (RoleAnnotDecl name roles) -> AST.RoleDecl <$> trfSimpleName name <*> makeList " " atTheEnd (mapM trfRole roles)
+  DefD (DefaultDecl types) -> AST.DefaultDecl . nonemptyAnnList <$> mapM trfType types
+  ForD (ForeignImport name (hsib_body -> typ) _ (CImport ccall safe _ _ _)) 
+    -> AST.ForeignImport <$> trfCallConv ccall <*> trfSafety (getLoc ccall) safe <*> define (trfName name) <*> trfType typ
+  ForD (ForeignExport name (hsib_body -> typ) _ (CExport (L l (CExportStatic _ _ ccall)) _)) 
+    -> AST.ForeignExport <$> annLoc (pure l) (trfCallConv' ccall) <*> trfName name <*> trfType typ
+  SpliceD (SpliceDecl (unLoc -> spl) _) -> AST.SpliceDecl <$> (annCont $ trfSplice' spl)
+  AnnD (HsAnnotation stxt subject expr) 
+    -> AST.PragmaDecl <$> annCont (AST.AnnPragma <$> 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.Decl r)
+trfGADT nd name vars ctx kind cons derivs ctxTok consLoc
+  = AST.GDataDecl <$> 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.Decl r)
+trfDataDef nd name vars ctx cons derivs ctxTok consLoc
+  = AST.DataDecl <$> 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.Decl r)
+trfVal (PatSynBind psb) = AST.PatternSynonymDecl <$> annCont (trfPatternSynonym psb)
+trfVal bind = AST.ValueBinding <$> (annCont $ trfBind' bind)
+
+trfSig :: TransformName n r => Sig n -> Trf (AST.Decl r)
+trfSig (ts @ (TypeSig {})) = AST.TypeSigDecl <$> defineTypeVars (annCont $ trfTypeSig' ts)
+trfSig (FixSig fs) = AST.FixityDecl <$> (annCont $ trfFixitySig fs)
+trfSig (PatSynSig id typ) 
+  = AST.PatTypeSigDecl <$> annCont (AST.PatternTypeSignature <$> trfName id <*> trfType (hsib_body typ))
+trfSig (InlineSig name (InlinePragma _ Inlinable _ phase _)) 
+  = AST.PragmaDecl <$> annCont (AST.InlinablePragma <$> 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.PragmaDecl <$> annCont ((case inl of Inline -> AST.InlinePragma; NoInline -> AST.NoInlinePragma) 
+                                     <$> trfConlike parts cl 
+                                     <*> trfPhase (pure $ srcSpanStart (getLoc name)) phase 
+                                     <*> trfName name)
+trfSig (SpecSig name (map hsib_body -> types) (inl_act -> phase)) 
+  = AST.PragmaDecl <$> annCont (AST.SpecializePragma <$> 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 :: RangeAnnot a => [SrcSpan] -> RuleMatchInfo -> Trf (AnnMaybe AST.ConlikeAnnot a)
+trfConlike parts ConLike = makeJust <$> annLoc (pure $ parts !! 2) (pure AST.ConlikeAnnot)
+trfConlike parts FunLike = nothing " " "" (pure $ srcSpanEnd $ parts !! 1)
+
+trfConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.ConDecl r)
+trfConDecl = trfLoc trfConDecl'
+
+trfConDecl' :: TransformName n r => ConDecl n -> Trf (AST.ConDecl r)
+trfConDecl' (ConDeclH98 { con_name = name, con_details = PrefixCon args })
+  = AST.ConDecl <$> define (trfName name) <*> makeList " " atTheEnd (mapM trfType args)
+trfConDecl' (ConDeclH98 { con_name = name, con_details = RecCon (unLoc -> flds) })
+  = AST.RecordDecl <$> define (trfName name) <*> (between AnnOpenC AnnCloseC $ trfAnnList ", " trfFieldDecl' flds)
+trfConDecl' (ConDeclH98 { con_name = name, con_details = InfixCon t1 t2 })
+  = AST.InfixConDecl <$> trfType t1 <*> define (trfOperator name) <*> trfType t2
+
+trfGADTConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.GadtConDecl r)
+trfGADTConDecl = trfLoc $ \(ConDeclGADT { con_names = names, con_type = hsib_body -> typ })
+  -> AST.GadtConDecl <$> define (trfAnnList ", " trfName' names) 
+                     <*> trfGadtConType typ
+
+trfGadtConType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.GadtConType r)
+trfGadtConType = trfLoc $ \case 
+  HsFunTy (cleanHsType . unLoc -> HsRecTy flds) resType 
+    -> AST.GadtRecordType <$> between AnnOpenC AnnCloseC (trfAnnList ", " trfFieldDecl' flds) 
+                          <*> trfType resType
+  typ -> AST.GadtNormalType <$> annCont (trfType' typ)
+
+trfFieldDecl :: TransformName n r => Located (ConDeclField n) -> Trf (Ann AST.FieldDecl r)
+trfFieldDecl = trfLoc trfFieldDecl'
+
+trfFieldDecl' :: TransformName n r => ConDeclField n -> Trf (AST.FieldDecl r)
+trfFieldDecl' (ConDeclField names typ _) = AST.FieldDecl <$> (define $ nonemptyAnnList <$> mapM (trfName . getFieldOccName) names) <*> trfType typ
+
+trfDerivings :: TransformName n r => Located [LHsSigType n] -> Trf (Ann AST.Deriving r)
+trfDerivings = trfLoc $ \case
+  [hsib_body -> typ@(unLoc -> HsTyVar cls)] -> AST.DerivingOne <$> trfInstanceHead typ
+  derivs -> AST.Derivings <$> trfAnnList ", " trfInstanceHead' (map hsib_body derivs)
+  
+trfInstanceRule :: TransformName n r => Located (HsType n) -> Trf (Ann AST.InstanceRule r)
+trfInstanceRule = trfLoc (trfInstanceRule' . cleanHsType)
+
+trfInstanceRule' :: TransformName n r => HsType n -> Trf (AST.InstanceRule r)
+trfInstanceRule' (HsForAllTy bndrs (unLoc -> HsQualTy ctx typ))
+  = AST.InstanceRule <$> (makeJust <$> annLoc (pure $ collectLocs bndrs) (trfBindings bndrs)) 
+                     <*> trfCtx (after AnnDot) ctx
+                     <*> trfInstanceHead typ
+trfInstanceRule' (HsQualTy ctx typ) = AST.InstanceRule <$> nothing "" " . " atTheStart 
+                                                       <*> trfCtx atTheStart ctx
+                                                       <*> trfInstanceHead typ
+trfInstanceRule' (HsParTy typ) = AST.InstanceParen <$> trfInstanceRule typ
+trfInstanceRule' (HsTyVar tv) = instanceHead $ annCont (AST.InstanceHeadCon <$> trfName tv)
+trfInstanceRule' (HsAppTy t1 t2) = instanceHead $ annCont (AST.InstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2)
+trfInstanceRule' t = error (showSDocUnsafe $ ppr t)
+
+instanceHead :: RangeAnnot r => Trf (Ann AST.InstanceHead r) -> Trf (AST.InstanceRule r)
+instanceHead hd = AST.InstanceRule <$> (nothing "" " . " atTheStart) <*> (nothing " " "" atTheStart) <*> hd
+                            
+makeInstanceRuleTyVars :: TransformName n r => Located n -> HsImplicitBndrs n [LHsType n] -> Trf (Ann AST.InstanceRule r)
+makeInstanceRuleTyVars n vars = annCont
+  $ AST.InstanceRule <$> nothing "" " . " atTheStart
+                     <*> nothing " " "" atTheStart
+                     <*> foldl (\c t -> annLoc (pure $ combineSrcSpans (getLoc n) (getLoc t)) $ AST.InstanceHeadApp <$> c <*> (trfType t))
+                               (copyAnnot AST.InstanceHeadCon (trfName n))
+                               (hsib_body vars)
+
+trfInstanceHead :: TransformName n r => Located (HsType n) -> Trf (Ann AST.InstanceHead r)
+trfInstanceHead = trfLoc trfInstanceHead'
+
+trfInstanceHead' :: TransformName n r => HsType n -> Trf (AST.InstanceHead r)
+trfInstanceHead' = trfInstanceHead'' . cleanHsType where
+  trfInstanceHead'' (HsForAllTy [] (unLoc -> t)) = trfInstanceHead' t
+  trfInstanceHead'' (HsTyVar tv) = AST.InstanceHeadCon <$> trfName tv
+  trfInstanceHead'' (HsAppTy t1 t2) = AST.InstanceHeadApp <$> trfInstanceHead t1 <*> trfType t2
+  trfInstanceHead'' (HsParTy typ) = AST.InstanceHeadParen <$> trfInstanceHead typ
+  trfInstanceHead'' (HsOpTy t1 op t2) 
+    = AST.InstanceHeadApp <$> (annLoc (pure $ combineSrcSpans (getLoc t1) (getLoc op))
+                                      (AST.InstanceHeadInfix <$> 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 (AnnList AST.TypeEqn r)
+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.TypeEqn r)
+trfTypeEq = trfLoc $ \(TyFamEqn name pats rhs) 
+  -> AST.TypeEqn <$> defineTypeVars (focusBefore AnnEqual (combineTypes name (hsib_body pats))) <*> trfType rhs
+  where combineTypes :: TransformName n r => Located n -> [LHsType n] -> Trf (Ann AST.Type r)
+        combineTypes name (lhs : rhs : rest) | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs)
+          = annCont $ AST.TyInfix <$> trfType lhs <*> trfOperator name <*> trfType rhs
+        combineTypes name pats = wrapTypes (annLoc (pure $ getLoc name) (AST.TyVar <$> trfName name)) pats
+
+        wrapTypes :: TransformName n r => Trf (Ann AST.Type r) -> [LHsType n] -> Trf (Ann AST.Type r)
+        wrapTypes base pats 
+          = foldl (\t p -> do typ <- t
+                              annLoc (pure $ combineSrcSpans (getRange $ _annotation typ) (getLoc p)) 
+                                     (AST.TyApp <$> pure typ <*> trfType p)) base pats
+                 
+trfFunDeps :: TransformName n r => [Located (FunDep (Located n))] -> Trf (AnnMaybe AST.FunDeps r)
+trfFunDeps [] = nothing "| " "" $ focusBeforeIfPresent AnnWhere atTheEnd
+trfFunDeps fundeps = makeJust <$> annLoc (combineSrcSpans (collectLocs fundeps) <$> tokenLoc AnnVbar) 
+                                         (AST.FunDeps <$> trfAnnList ", " trfFunDep' fundeps)
+  
+trfFunDep' :: TransformName n r => FunDep (Located n) -> Trf (AST.FunDep r)
+trfFunDep' (lhs, rhs) = AST.FunDep <$> trfAnnList ", " trfName' lhs <*> trfAnnList ", " trfName' rhs
+
+createDeclHead :: TransformName n r => Located n -> LHsQTyVars n -> Trf (Ann AST.DeclHead r)
+createDeclHead name (hsq_explicit -> lhs : rhs : rest)
+  | srcSpanStart (getLoc name) > srcSpanEnd (getLoc lhs)
+  -- infix declaration
+  = wrapDeclHead rest
+      $ annLoc (addParenLocs $ getLoc lhs `combineSrcSpans` getLoc rhs) 
+               (AST.DHInfix <$> defineTypeVars (trfTyVar lhs) <*> define (trfOperator name) <*> defineTypeVars (trfTyVar rhs))
+createDeclHead name vars = defineTypeVars $ wrapDeclHead (hsq_explicit vars) (define $ copyAnnot AST.DeclHead (trfName name))
+
+wrapDeclHead :: TransformName n r => [LHsTyVarBndr n] -> Trf (Ann AST.DeclHead r) -> Trf (Ann AST.DeclHead r)
+wrapDeclHead vars base
+  = foldl (\t p -> do typ <- t 
+                      annLoc (addParenLocs $ combineSrcSpans (getRange $ _annotation typ) (getLoc p)) 
+                             (AST.DHApp 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 (AnnMaybe AST.ClassBody r)
+createClassBody sigs binds typeFams typeFamDefs 
+  = do isThereWhere <- isGoodSrcSpan <$> (tokenLoc AnnWhere)
+       if isThereWhere 
+         then makeJust <$> annLoc (combinedLoc <$> tokenLoc AnnWhere) 
+                                  (AST.ClassBody <$> 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.ClsDef . trfBind) (bagToList binds)
+        getFams = mapM (copyAnnot AST.ClsTypeFam . trfTypeFam) typeFams
+        getFamDefs = mapM trfTypeFamDef typeFamDefs
+       
+trfClassElemSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.ClassElement r)
+trfClassElemSig = trfLoc $ \case
+  TypeSig names typ -> AST.ClsSig <$> (annCont $ AST.TypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) 
+                                  <*> trfType (hswc_body $ hsib_body typ))
+  ClassOpSig True [name] typ -> AST.ClsDefSig <$> trfName name <*> trfType (hsib_body typ)
+  ClassOpSig False names typ -> AST.ClsSig <$> (annCont $ AST.TypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) 
+                                           <*> trfType (hsib_body typ))
+  MinimalSig _ formula -> AST.ClsMinimal <$> trfMinimalFormula formula
+  s -> error ("Illegal signature: " ++ showSDocUnsafe (ppr s) ++ " (ctor: " ++ show (toConstr s) ++ ")")
+         
+trfTypeFam :: TransformName n r => Located (FamilyDecl n) -> Trf (Ann AST.TypeFamily r)
+trfTypeFam = trfLoc trfTypeFam'
+
+trfTypeFam' :: TransformName n r => FamilyDecl n -> Trf (AST.TypeFamily r)
+trfTypeFam' (FamilyDecl DataFamily name tyVars kindSig _)
+  = AST.DataFamily <$> (case unLoc kindSig of KindSig _ -> between AnnData AnnDcolon; _ -> id) (createDeclHead name tyVars) 
+                   <*> trfFamilyKind kindSig
+trfTypeFam' (FamilyDecl OpenTypeFamily name tyVars kindSig injectivity)
+  = AST.TypeFamily <$> (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.ClassElement r)
+trfTypeFamDef = trfLoc $ \(TyFamEqn con pats rhs) 
+  -> AST.ClsTypeDef <$> between AnnType AnnEqual (createDeclHead con pats) <*> trfType rhs
+          
+trfInstBody :: TransformName n r => LHsBinds n -> [LSig n] -> [LTyFamInstDecl n] -> [LDataFamInstDecl n] -> Trf (AnnMaybe AST.InstBody r)
+trfInstBody binds sigs fams dats = do
+    wh <- tokenLoc AnnWhere
+    if isGoodSrcSpan wh then
+      makeJust <$> annLoc (combinedLoc <$> tokenLoc AnnWhere) 
+                          (AST.InstBody <$> (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.InstBodyNormalDecl . trfBind) (bagToList binds)
+        getFams = mapM trfInstTypeFam fams
+        getDats = mapM trfInstDataFam dats
+          
+trfClassInstSig :: TransformName n r => Located (Sig n) -> Trf (Ann AST.InstBodyDecl r)
+trfClassInstSig = trfLoc $ \case
+  TypeSig names typ -> AST.InstBodyTypeSig <$> (annCont $ AST.TypeSignature <$> makeNonemptyList ", " (mapM trfName names) 
+                                           <*> trfType (hswc_body $ hsib_body typ))
+  ClassOpSig _ names typ -> AST.InstBodyTypeSig <$> (annCont $ AST.TypeSignature <$> define (makeNonemptyList ", " (mapM trfName names)) 
+                                                <*> trfType (hsib_body typ))
+  SpecInstSig _ typ -> AST.SpecializeInstance <$> 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.InstBodyDecl r)
+trfInstTypeFam (unLoc -> TyFamInstDecl eqn _) = copyAnnot AST.InstBodyTypeDecl (trfTypeEq eqn)
+
+trfInstDataFam :: TransformName n r => Located (DataFamInstDecl n) -> Trf (Ann AST.InstBodyDecl r)
+trfInstDataFam = trfLoc $ \case 
+  (DataFamInstDecl tc (hsib_body -> pats) (HsDataDefn dn ctx _ _ cons derivs) _) 
+    -> AST.InstBodyDataDecl 
+         <$> trfDataKeyword dn 
+         <*> annLoc (pure $ collectLocs pats `combineSrcSpans` getLoc tc `combineSrcSpans` getLoc ctx)
+                    (AST.InstanceRule <$> nothing "" " . " atTheStart
+                                      <*> trfCtx atTheStart ctx 
+                                      <*> foldr (\t r -> annLoc (combineSrcSpans (getLoc t) . getRange . _annotation <$> r) 
+                                                                (AST.InstanceHeadApp <$> r <*> (trfType t))) 
+                                                (copyAnnot AST.InstanceHeadCon (trfName tc)) pats)
+         <*> trfAnnList "" trfConDecl' cons
+         <*> trfMaybe " deriving " "" trfDerivings derivs
+          
+trfPatternSynonym :: forall n r . TransformName n r => PatSynBind n n -> Trf (AST.PatternSynonym r)
+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.PatternSynonym <$> trfPatSynLhs id lhs
+                           <*> annLoc rhsLoc (trfPatSynRhs dir changedRhs)
+
+  where trfPatSynLhs :: TransformName n r => Located n -> HsPatSynDetails (Located n) -> Trf (Ann AST.PatSynLhs r)
+        trfPatSynLhs id (PrefixPatSyn args)
+          = annLoc (pure $ foldLocs (getLoc id : map getLoc args)) $ AST.NormalPatSyn <$> trfName id <*> trfAnnList " " trfName' args
+        trfPatSynLhs op (InfixPatSyn lhs rhs)
+          = annLoc (pure $ getLoc lhs `combineSrcSpans` getLoc rhs) $ AST.InfixPatSyn <$> trfName lhs <*> trfOperator op <*> trfName rhs
+        trfPatSynLhs id (RecordPatSyn flds)
+          = annLoc (mkSrcSpan (srcSpanStart (getLoc id)) <$> before AnnEqual) 
+              $ AST.RecordPatSyn <$> trfName id <*> trfAnnList ", " trfName' (map recordPatSynSelectorId flds)
+
+        trfPatSynRhs :: TransformName n r => HsPatSynDir n -> Located (Pat n) -> Trf (AST.PatSynRhs r)
+        trfPatSynRhs ImplicitBidirectional pat = AST.BidirectionalPatSyn <$> trfPattern pat <*> nothing " where " "" atTheEnd
+        trfPatSynRhs (ExplicitBidirectional mg) pat = AST.BidirectionalPatSyn <$> trfPattern pat <*> (makeJust <$> trfPatSynWhere mg)
+        trfPatSynRhs Unidirectional pat = AST.OneDirectionalPatSyn <$> trfPattern pat
+        trfPatSynWhere :: TransformName n r => MatchGroup n (LHsExpr n) -> Trf (Ann AST.PatSynWhere r)
+        trfPatSynWhere (MG { mg_alts = alts }) = annLoc (pure $ getLoc alts) (AST.PatSynWhere <$> makeIndentedList (after AnnWhere) (mapM (trfMatch (unLoc id)) (unLoc alts)))
+
+trfFamilyKind :: TransformName n r => Located (FamilyResultSig n) -> Trf (AnnMaybe AST.KindConstraint r)
+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 (AnnMaybe AST.TypeFamilySpec r)
+trfFamilyResultSig (L l fr) Nothing = case fr of 
+  NoSig -> nothing "" " " atTheEnd
+  KindSig k -> makeJust <$> (annLoc (pure l) $ AST.TypeFamilyKind <$> trfKindSig' k)
+trfFamilyResultSig _ (Just (L l (InjectivityAnn n deps))) 
+  = makeJust <$> (annLoc (pure l) $ AST.TypeFamilyInjectivity <$> (annCont $ AST.InjectivityAnn <$> trfName n <*> trfAnnList ", " trfName' deps))
+
+trfAnnotationSubject :: TransformName n r => SourceText -> AnnProvenance n -> SrcLoc -> Trf (Ann AST.AnnotationSubject r)
+trfAnnotationSubject stxt subject payloadEnd
+  = do payloadStart <- advanceStr stxt <$> atTheStart
+       case subject of ValueAnnProvenance name@(L l _) -> annLoc (pure l) (AST.NameAnnotation <$> trfName name)
+                       TypeAnnProvenance name@(L l _) -> annLoc (pure $ mkSrcSpan payloadStart (srcSpanEnd l)) 
+                                                                (AST.TypeAnnotation <$> trfName name)
+                       ModuleAnnProvenance -> annLoc (pure $ mkSrcSpan payloadStart payloadEnd) (pure AST.ModuleAnnotation)

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

@@ -0,0 +1,210 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , ScopedTypeVariables
+           , TypeApplications
+           , AllowAmbiguousTypes
+           #-}
+module Language.Haskell.Tools.AST.FromGHC.Exprs where
+
+import Data.Maybe
+import Data.Data (toConstr)
+import Control.Monad.Reader
+import Control.Reference
+
+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 Language.Haskell.Tools.AST.FromGHC.Base
+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 (Ann(..), AnnList(..))
+import qualified Language.Haskell.Tools.AST as AST
+
+import Debug.Trace
+
+trfExpr :: forall n r . TransformName n r => Located (HsExpr n) -> Trf (Ann AST.Expr r)
+-- correction for empty cases (TODO: put of and {} inside)
+trfExpr (L l cs@(HsCase expr (unLoc . mg_alts -> []))) 
+  = addScopeInfo @n =<< annLoc (pure $ combineSrcSpans l (getLoc expr)) (trfExpr' cs)
+trfExpr e = addScopeInfo @n =<< trfLoc trfExpr' e
+
+addScopeInfo :: forall n r . TransformName n r => Ann AST.Expr r -> Trf (Ann AST.Expr r)
+addScopeInfo expr = do scope <- asks localsInScope
+                       return $ AST.annotation .- addSemanticInfo (AST.ScopeInfo scope :: AST.SemanticInfo n) $ expr
+
+trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.Expr r)
+trfExpr' (HsVar name) = AST.Var <$> trfName name
+trfExpr' (HsRecFld fld) = AST.Var <$> (asks contRange >>= \l -> trfAmbiguousFieldName' l fld)
+trfExpr' (HsIPVar (HsIPName ip)) = AST.Var <$> annCont (AST.NormalName <$> annCont (AST.nameFromList <$> trfNameStr (unpackFS ip)))
+trfExpr' (HsOverLit (ol_val -> val)) = AST.Lit <$> annCont (trfOverloadedLit val)
+trfExpr' (HsLit val) = AST.Lit <$> annCont (trfLiteral' val)
+trfExpr' (HsLam (unLoc . mg_alts -> [unLoc -> Match _ pats _ (GRHSs [unLoc -> GRHS [] expr] (unLoc -> EmptyLocalBinds))]))
+  = AST.Lambda <$> (trfAnnList " " trfPattern' pats) <*> addToScope pats (trfExpr expr)
+trfExpr' (HsLamCase _ (unLoc . mg_alts -> matches)) = AST.LamCase <$> trfAnnList " " trfAlt' matches
+trfExpr' (HsApp e1 e2) = AST.App <$> trfExpr e1 <*> trfExpr e2
+trfExpr' (OpApp e1 (unLoc -> HsVar op) _ e2) 
+  = AST.InfixApp <$> trfExpr e1 <*> trfOperator op <*> trfExpr e2
+trfExpr' (NegApp e _) = AST.PrefixApp <$> annLoc loc (AST.NormalOp <$> annLoc loc (AST.nameFromList <$> trfNameStr "-"))
+                                      <*> trfExpr e
+  where loc = mkSrcSpan <$> atTheStart <*> (pure $ srcSpanStart (getLoc e))
+trfExpr' (HsPar (unLoc -> SectionL expr (unLoc -> HsVar op))) = AST.LeftSection <$> trfExpr expr <*> trfOperator op
+trfExpr' (HsPar (unLoc -> SectionR (unLoc -> HsVar op) expr)) = AST.RightSection <$> trfOperator op <*> trfExpr expr
+trfExpr' (HsPar expr) = AST.Paren <$> 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.Tuple else AST.UnboxedTuple
+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.TupleSection else AST.UnboxedTupSec
+        trfTupSecElem :: forall n r . TransformName n r => (HsTupArg n, SrcSpan) -> Trf (Ann AST.TupSecElem r)
+        trfTupSecElem (Present e, l) 
+          = annLoc (pure l) (AST.Present <$> (addScopeInfo @n =<< annCont (trfExpr' (unLoc e))))
+        trfTupSecElem (Missing _, l) = annLoc (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.Case <$> trfExpr expr <*> (makeIndentedList (focusBeforeIfPresent AnnCloseC atTheEnd) (mapM trfAlt cases))
+trfExpr' (HsIf _ expr thenE elseE) = AST.If <$> trfExpr expr <*> trfExpr thenE <*> trfExpr elseE
+trfExpr' (HsMultiIf _ parts) = AST.MultiIf <$> trfAnnList "" trfGuardedCaseRhs' parts
+trfExpr' (HsLet (unLoc -> binds) expr) = addToScope binds (AST.Let <$> trfLocalBinds binds <*> trfExpr expr)
+trfExpr' (HsDo DoExpr (unLoc -> stmts) _) = AST.Do <$> annLoc (tokenLoc AnnDo) (pure AST.DoKeyword) 
+                                                   <*> makeNonemptyIndentedList (trfScopedSequence trfDoStmt stmts)
+trfExpr' (HsDo MDoExpr (unLoc -> [unLoc -> RecStmt { recS_stmts = stmts }, lastStmt]) _) 
+  = AST.Do <$> annLoc (tokenLoc AnnMdo) (pure AST.MDoKeyword)
+           <*> addToScope stmts (makeNonemptyIndentedList (mapM trfDoStmt (stmts ++ [lastStmt])))
+trfExpr' (HsDo MDoExpr (unLoc -> stmts) _) = AST.Do <$> annLoc (tokenLoc AnnMdo) (pure AST.MDoKeyword)
+                                                    <*> addToScope stmts (makeNonemptyIndentedList (mapM trfDoStmt stmts))
+-- TODO: scoping
+trfExpr' (HsDo ListComp (unLoc -> stmts) _)
+  = AST.ListComp <$> trfExpr (getLastStmt stmts) <*> trfListCompStmts stmts
+trfExpr' (HsDo MonadComp (unLoc -> stmts) _)
+  = AST.ListComp <$> trfExpr (getLastStmt stmts) <*> trfListCompStmts stmts
+trfExpr' (HsDo PArrComp (unLoc -> stmts) _)
+  = AST.ParArrayComp <$> trfExpr (getLastStmt stmts) <*> trfListCompStmts stmts
+trfExpr' (ExplicitList _ _ exprs) = AST.List <$> trfAnnList' ", " trfExpr exprs
+trfExpr' (ExplicitPArr _ exprs) = AST.ParArray <$> trfAnnList' ", " trfExpr exprs
+trfExpr' (RecordCon name _ _ fields) = AST.RecCon <$> trfName name <*> trfFieldInits fields
+trfExpr' (RecordUpd expr fields _ _ _ _) = AST.RecUpdate <$> trfExpr expr <*> trfAnnList ", " trfFieldUpdate fields
+trfExpr' (ExprWithTySig expr typ) = AST.TypeSig <$> trfExpr expr <*> trfType (hswc_body $ hsib_body typ)
+trfExpr' (ArithSeq _ _ (From from)) = AST.Enum <$> trfExpr from <*> nothing "," "" (before AnnDotdot)
+                                                                <*> nothing "" "" (before AnnCloseS)
+trfExpr' (ArithSeq _ _ (FromThen from step)) 
+  = AST.Enum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> nothing "" "" (before AnnCloseS) 
+trfExpr' (ArithSeq _ _ (FromTo from to)) 
+  = AST.Enum <$> trfExpr from <*> nothing "," "" (before AnnDotdot)
+                              <*> (makeJust <$> trfExpr to)
+trfExpr' (ArithSeq _ _ (FromThenTo from step to)) 
+  = AST.Enum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> (makeJust <$> trfExpr to)
+trfExpr' (PArrSeq _ (FromTo from to)) 
+  = AST.ParArrayEnum <$> trfExpr from <*> nothing "," "" (before AnnDotdot) <*> trfExpr to
+trfExpr' (PArrSeq _ (FromThenTo from step to)) 
+  = AST.ParArrayEnum <$> trfExpr from <*> (makeJust <$> trfExpr step) <*> trfExpr to
+-- TODO: SCC, CORE, GENERATED annotations
+trfExpr' (HsBracket brack) = AST.BracketExpr <$> annCont (trfBracket' brack)
+trfExpr' (HsRnBracketOut brack _) = AST.BracketExpr <$> annCont (trfBracket' brack)
+trfExpr' (HsTcBracketOut brack _) = AST.BracketExpr <$> annCont (trfBracket' brack)
+trfExpr' (HsSpliceE qq@(HsQuasiQuote {})) = AST.QuasiQuoteExpr <$> annCont (trfQuasiQuotation' qq)
+trfExpr' (HsSpliceE splice) = AST.Splice <$> annCont (trfSplice' splice)
+trfExpr' (HsProc pat cmdTop) = AST.Proc <$> trfPattern pat <*> trfCmdTop cmdTop
+trfExpr' (HsStatic expr) = AST.StaticPtr <$> trfExpr expr
+trfExpr' (HsAppType expr typ) = AST.ExplTypeApp <$> 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 (AnnList AST.FieldUpdate r)
+trfFieldInits (HsRecFields fields dotdot) 
+  = do cont <- asks contRange
+       makeList ", " (before AnnCloseC)
+         $ ((++) <$> mapM trfFieldInit (filter ((cont /=) . getLoc) fields) 
+                  <*> (if isJust dotdot then (:[]) <$> annLoc (tokenLoc AnnDotdot) 
+                                                              (pure AST.FieldWildcard) 
+                                        else pure []))
+  
+trfFieldInit :: TransformName n r => Located (HsRecField n (LHsExpr n)) -> Trf (Ann AST.FieldUpdate r)
+trfFieldInit = trfLoc $ \case
+  HsRecField id _ True -> AST.FieldPun <$> trfName (getFieldOccName id)
+  HsRecField id val False -> AST.NormalFieldUpdate <$> trfName (getFieldOccName id) <*> trfExpr val
+  
+trfFieldUpdate :: TransformName n r => HsRecField' (AmbiguousFieldOcc n) (LHsExpr n) -> Trf (AST.FieldUpdate r)
+trfFieldUpdate (HsRecField id _ True) = AST.FieldPun <$> trfAmbiguousFieldName id
+trfFieldUpdate (HsRecField id val False) = AST.NormalFieldUpdate <$> trfAmbiguousFieldName id <*> trfExpr val
+
+trfAlt :: TransformName n r => Located (Match n (LHsExpr n)) -> Trf (Ann AST.Alt r)
+trfAlt = trfLoc trfAlt'
+
+trfAlt' :: TransformName n r => Match n (LHsExpr n) -> Trf (AST.Alt r)
+trfAlt' = gTrfAlt' trfExpr
+
+gTrfAlt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae r)) -> Match n (Located (ge n)) -> Trf (AST.Alt' ae r)
+gTrfAlt' te (Match _ [pat] typ (GRHSs rhss (unLoc -> locBinds)))
+  = AST.Alt <$> trfPattern pat <*> gTrfCaseRhss te rhss <*> trfWhereLocalBinds locBinds
+  
+trfCaseRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.CaseRhs r)
+trfCaseRhss = gTrfCaseRhss trfExpr
+
+gTrfCaseRhss :: TransformName n r => (Located (ge n) -> Trf (Ann ae r)) -> [Located (GRHS n (Located (ge n)))] -> Trf (Ann (AST.CaseRhs' ae) r)
+gTrfCaseRhss te [unLoc -> GRHS [] body] = annLoc (combineSrcSpans (getLoc body) <$> tokenLocBack AnnRarrow) 
+                                                 (AST.UnguardedCaseRhs <$> te body)
+gTrfCaseRhss te rhss = annLoc (pure $ collectLocs rhss) 
+                              (AST.GuardedCaseRhss <$> trfAnnList ";" (gTrfGuardedCaseRhs' te) rhss)
+  
+trfGuardedCaseRhs :: TransformName n r => Located (GRHS n (LHsExpr n)) -> Trf (Ann AST.GuardedCaseRhs r)
+trfGuardedCaseRhs = trfLoc trfGuardedCaseRhs' 
+
+trfGuardedCaseRhs' :: TransformName n r => GRHS n (LHsExpr n) -> Trf (AST.GuardedCaseRhs r)
+trfGuardedCaseRhs' = gTrfGuardedCaseRhs' trfExpr
+
+gTrfGuardedCaseRhs' :: TransformName n r => (Located (ge n) -> Trf (Ann ae r)) -> GRHS n (Located (ge n)) -> Trf (AST.GuardedCaseRhs' ae r)
+gTrfGuardedCaseRhs' te (GRHS guards body) = AST.GuardedCaseRhs <$> trfAnnList " " trfRhsGuard' guards <*> te body
+
+trfCmdTop :: TransformName n r => Located (HsCmdTop n) -> Trf (Ann AST.Cmd r)
+trfCmdTop (L _ (HsCmdTop cmd _ _ _)) = trfCmd cmd
+
+trfCmd :: TransformName n r => Located (HsCmd n) -> Trf (Ann AST.Cmd r)
+trfCmd = trfLoc trfCmd'
+
+trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.Cmd r)
+trfCmd' (HsCmdArrApp left right _ typ dir) = AST.ArrowAppCmd <$> trfExpr left <*> op <*> trfExpr right 
+  where op = case (typ, dir) of (HsFirstOrderApp, False) -> annLoc (tokenLoc Annrarrowtail) (pure AST.RightAppl)
+                                (HsFirstOrderApp, True) -> annLoc (tokenLoc Annlarrowtail) (pure AST.LeftAppl)
+                                (HsHigherOrderApp, False) -> annLoc (tokenLoc AnnRarrowtail) (pure AST.RightHighApp)
+                                (HsHigherOrderApp, True) -> annLoc (tokenLoc AnnLarrowtail) (pure AST.LeftHighApp)
+                                                                       -- FIXME: needs a before 
+trfCmd' (HsCmdArrForm expr _ cmds) = AST.ArrowFormCmd <$> trfExpr expr <*> makeList " " (before AnnClose) (mapM trfCmdTop cmds)
+trfCmd' (HsCmdApp cmd expr) = AST.AppCmd <$> trfCmd cmd <*> trfExpr expr
+trfCmd' (HsCmdLam (MG (unLoc -> [unLoc -> Match _ pats _ (GRHSs [unLoc -> GRHS [] body] _)]) _ _ _)) 
+  = AST.LambdaCmd <$> trfAnnList " " trfPattern' pats <*> trfCmd body
+trfCmd' (HsCmdPar cmd) = AST.ParenCmd <$> trfCmd cmd
+trfCmd' (HsCmdCase expr (MG (unLoc -> alts) _ _ _)) 
+  = AST.CaseCmd <$> trfExpr expr <*> makeNonemptyIndentedList (mapM (trfLoc (gTrfAlt' trfCmd)) alts) 
+trfCmd' (HsCmdIf _ pred thenExpr elseExpr) = AST.IfCmd <$> trfExpr pred <*> trfCmd thenExpr <*> trfCmd elseExpr
+trfCmd' (HsCmdLet (unLoc -> binds) cmd) = addToScope binds (AST.LetCmd <$> trfLocalBinds binds <*> trfCmd cmd)
+trfCmd' (HsCmdDo (unLoc -> stmts) _) = AST.DoCmd <$> makeNonemptyIndentedList (mapM (trfLoc (gTrfDoStmt' trfCmd)) stmts)

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

@@ -0,0 +1,16 @@+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.Base
+import Language.Haskell.Tools.AST (Ann(..))
+import qualified Language.Haskell.Tools.AST as AST
+
+trfExpr :: TransformName n r => Located (HsExpr n) -> Trf (Ann AST.Expr r)
+trfExpr' :: TransformName n r => HsExpr n -> Trf (AST.Expr r)
+
+trfCmd' :: TransformName n r => HsCmd n -> Trf (AST.Cmd r)

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

@@ -0,0 +1,187 @@+{-# LANGUAGE MultiParamTypeClasses
+           , TypeSynonymInstances
+           , FlexibleInstances
+           , ScopedTypeVariables
+           , ViewPatterns
+           #-}
+module Language.Haskell.Tools.AST.FromGHC.GHCUtils where
+
+import Data.List
+
+import GHC
+import Bag
+import RdrName
+import OccName
+import Name
+import Outputable
+import SrcLoc
+
+class OutputableBndr name => GHCName name where 
+  rdrName :: name -> RdrName
+  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
+  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
+  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
+
+
+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 _ = []
+
+-- | 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,62 @@+{-# LANGUAGE ViewPatterns #-}
+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.Base
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+
+import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..))
+import qualified Language.Haskell.Tools.AST as AST
+
+import Debug.Trace
+
+trfKindSig :: TransformName n r => Maybe (LHsKind n) -> Trf (AnnMaybe AST.KindConstraint r)
+trfKindSig = trfMaybe "" "" trfKindSig'
+
+trfKindSig' :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.KindConstraint r)
+trfKindSig' k = annLoc (combineSrcSpans (getLoc k) <$> (tokenBefore (srcSpanStart (getLoc k)) AnnDcolon)) 
+                       (AST.KindConstraint <$> trfLoc trfKind' k)
+
+trfKind :: TransformName n r => Located (HsKind n) -> Trf (Ann AST.Kind r)
+trfKind = trfLoc (trfKind' . cleanHsType)
+
+trfKind' :: TransformName n r => HsKind n -> Trf (AST.Kind r)
+trfKind' = trfKind'' . cleanHsType where
+  trfKind'' (HsTyVar (rdrName . unLoc -> Exact n)) 
+    | isWiredInName n && occNameString (nameOccName n) == "*"
+    = pure AST.KindStar
+    | isWiredInName n && occNameString (nameOccName n) == "#"
+    = pure AST.KindUnbox
+  trfKind'' (HsParTy kind) = AST.KindParen <$> trfKind kind
+  trfKind'' (HsFunTy k1 k2) = AST.KindFn <$> trfKind k1 <*> trfKind k2
+  trfKind'' (HsAppTy k1 k2) = AST.KindApp <$> trfKind k1 <*> trfKind k2
+  trfKind'' (HsTyVar kv) = transformingPossibleVar kv (AST.KindVar <$> trfName kv)
+  trfKind'' (HsListTy kind) = AST.KindList <$> trfKind kind
+  trfKind'' (HsAppsTy [unLoc -> HsAppPrefix t]) = trfKind' (unLoc t)
+  trfKind'' (HsAppsTy [unLoc -> HsAppInfix n]) = AST.KindVar <$> trfName n
+  trfKind'' pt@(HsExplicitListTy {}) = AST.KindPromoted <$> annCont (trfPromoted' trfKind' pt) 
+  trfKind'' pt@(HsExplicitTupleTy {}) = AST.KindPromoted <$> annCont (trfPromoted' trfKind' pt) 
+  trfKind'' pt@(HsTyLit {}) = AST.KindPromoted <$> annCont (trfPromoted' trfKind' pt) 
+  trfKind'' k = error ("Illegal kind: " ++ showSDocUnsafe (ppr k) ++ " (ctor: " ++ show (toConstr k) ++ ")")
+
+trfPromoted' :: TransformName n r => (HsType n -> Trf (a r)) -> HsType n -> Trf (AST.Promoted a r)
+trfPromoted' f (HsTyLit (HsNumTy _ int)) = pure $ AST.PromotedInt int
+trfPromoted' f (HsTyLit (HsStrTy _ str)) = pure $ AST.PromotedString (unpackFS str)
+trfPromoted' f (HsTyVar name) = AST.PromotedCon <$> trfName name
+trfPromoted' f (HsExplicitListTy _ elems) = AST.PromotedList <$> between AnnOpenS AnnCloseS (trfAnnList ", " f elems)
+trfPromoted' f (HsExplicitTupleTy _ elems) = AST.PromotedTuple <$> 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,36 @@+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.Base
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+
+import qualified Language.Haskell.Tools.AST as AST
+
+trfLiteral' :: HsLit -> Trf (AST.Literal a)
+trfLiteral' (HsChar _ ch) = pure $ AST.CharLit ch
+trfLiteral' (HsCharPrim _ ch) = pure $ AST.PrimCharLit ch
+trfLiteral' (HsString _ str) = pure $ AST.StringLit (unpackFS str)
+trfLiteral' (HsStringPrim _ str) = pure $ AST.PrimStringLit (BS.foldr (:) "" str)
+trfLiteral' (HsInt _ i) = pure $ AST.IntLit i
+trfLiteral' (HsIntPrim _ i) = pure $ AST.PrimIntLit i
+trfLiteral' (HsWordPrim _ i) = pure $ AST.PrimWordLit i
+trfLiteral' (HsInt64Prim _ i) = pure $ AST.PrimIntLit i
+trfLiteral' (HsWord64Prim _ i) = pure $ AST.PrimWordLit i
+trfLiteral' (HsInteger _ i _) = pure $ AST.PrimIntLit i
+trfLiteral' (HsRat frac _) = pure $ AST.FracLit (fl_value frac)
+trfLiteral' (HsFloatPrim frac) = pure $ AST.PrimFloatLit (fl_value frac)
+trfLiteral' (HsDoublePrim frac) = pure $ AST.PrimDoubleLit (fl_value frac)
+  
+trfOverloadedLit :: OverLitVal -> Trf (AST.Literal a)
+trfOverloadedLit (HsIntegral _ i) = pure $ AST.IntLit i
+trfOverloadedLit (HsFractional frac) = pure $ AST.FracLit (fl_value frac)
+trfOverloadedLit (HsIsString _ str) = pure $ AST.StringLit (unpackFS str)

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

@@ -0,0 +1,228 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , FlexibleContexts
+           , ScopedTypeVariables
+           , TypeApplications
+           #-}
+module Language.Haskell.Tools.AST.FromGHC.Modules where
+
+import Control.Reference hiding (element)
+import Data.Maybe
+import Data.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 Data.StructuralTraversal
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+
+import Avail as GHC
+import GHC as 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 Language.Haskell.TH.LanguageExtensions
+
+import Language.Haskell.Tools.AST (Ann(..), AnnMaybe(..), AnnList(..), RangeWithName, RangeWithType, RangeInfo
+                                  , SemanticInfo(..), semanticInfo, sourceInfo, semantics, annotation, nameInfo, nodeSpan)
+import qualified Language.Haskell.Tools.AST as AST
+
+import Language.Haskell.Tools.AST.FromGHC.Base
+import Language.Haskell.Tools.AST.FromGHC.Decls
+import Language.Haskell.Tools.AST.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.Utils
+
+addTypeInfos :: LHsBinds Id -> Ann AST.Module RangeWithName -> Ghc (Ann AST.Module RangeWithType)
+addTypeInfos bnds mod = traverseDown (return ()) (return ()) replaceNodeInfo mod
+  where replaceNodeInfo :: RangeWithName -> Ghc RangeWithType
+        replaceNodeInfo = semanticInfo !~ replaceSemanticInfo
+        replaceSemanticInfo NoSemanticInfo = return NoSemanticInfo
+        replaceSemanticInfo (ScopeInfo sc) = return $ ScopeInfo sc
+        replaceSemanticInfo (AmbiguousNameInfo sc d rdr l) = return $ NameInfo sc d (locMapping ! l)
+        replaceSemanticInfo (ModuleInfo mod imps) = ModuleInfo mod <$> mapM getType' imps
+        replaceSemanticInfo (NameInfo sc def ni) = NameInfo sc def <$> getType' ni
+        replaceSemanticInfo (ImportInfo mod access used) = ImportInfo mod <$> mapM getType' access <*> mapM getType' used
+        
+        getType' :: GHC.Name -> Ghc GHC.Id
+        getType' name = fromMaybe (error $ "Type of name '" ++ showSDocUnsafe (ppr name) ++ "' cannot be found") <$> getType name
+        getType 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 -> case Map.lookup name mapping of 
+                           Just id -> return (Just id)
+                           Nothing | isTyVarName name
+                                      -- unit type is for cases we don't know the kind
+                                   -> return $ Just $ mkVanillaGlobal name unitTy
+                           Nothing -> return Nothing
+        mapping = Map.fromList $ map (\id -> (getName id, id)) $ extractTypes bnds
+        locMapping = Map.fromList $ map (\(L l id) -> (l, id)) $ extractExprIds bnds
+        createPatSynType patSyn = case patSynSig patSyn of (_, _, _, _, args, res) -> mkFunTys args res
+
+getTypeVariables :: GHC.TyCon -> [Id]
+getTypeVariables tc
+  = tyConTyVars tc ++ maybe [] (\case (ClosedSynFamilyTyCon ax) -> maybe [] (concatMap cab_tvs . fromBranches . co_ax_branches) ax
+                                      _ -> []) (famTyConFlav_maybe tc)
+
+extractTypes :: LHsBinds Id -> [Id]
+extractTypes = concatMap universeBi . bagToList
+
+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); _ -> Nothing) . concatMap universeBi . bagToList
+
+
+trfModule :: Located (HsModule RdrName) -> Trf (Ann AST.Module RangeInfo)
+trfModule = trfLocCorrect (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) $ 
+  \(HsModule name exports imports decls deprec _) -> 
+    AST.Module <$> trfFilePragmas
+               <*> trfModuleHead name exports deprec
+               <*> trfImports imports
+               <*> trfDecls decls
+       
+trfModuleRename :: Module -> Ann AST.Module RangeInfo -> (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString) -> Located (HsModule RdrName) -> Trf (Ann AST.Module RangeWithName)
+trfModuleRename mod rangeMod (gr,imports,exps,_) hsMod = do 
+  prelude <- lift (xopt ImplicitPrelude . ms_hspp_opts <$> getModSummary (moduleName mod))
+  (_,preludeImports) <- if prelude then getImportedNames "Prelude" Nothing else return (mod, [])
+  let addModuleInfo :: Module -> Ann AST.Module RangeWithName -> Trf (Ann AST.Module RangeWithName)
+      addModuleInfo m = AST.semantics != ModuleInfo m preludeImports
+  addModuleInfo mod =<< trfLocCorrect (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) (trfModuleRename' preludeImports) hsMod
+        
+  where originalNames = Map.fromList $ catMaybes $ map getSourceAndInfo (rangeMod ^? biplateRef) 
+        getSourceAndInfo :: Ann AST.SimpleName RangeInfo -> 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)
+          setOriginalNames originalNames
+            $ AST.Module <$> trfFilePragmas
+                         <*> trfModuleHead name (case (exports, exps) of (Just (L l _), Just ie) -> Just (L l ie)
+                                                                         _                       -> Nothing) deprec
+                         <*> return transformedImports
+                         <*> addToScope (concat @[] (transformedImports ^? AST.annList&semantics&AST.importedNames) ++ preludeImports) (trfDeclsGroup gr)
+
+trfModuleHead :: TransformName n r => Maybe (Located ModuleName) -> Maybe (Located [LIE n]) -> Maybe (Located WarningTxt) -> Trf (AnnMaybe AST.ModuleHead r) 
+trfModuleHead (Just mn) exports modPrag
+  = makeJust <$> (annLoc (tokensLoc [AnnModule, AnnWhere])
+                         (AST.ModuleHead <$> trfModuleName mn 
+                                         <*> trfExportList (srcSpanEnd $ getLoc mn) exports
+                                         <*> trfModulePragma modPrag))
+trfModuleHead _ Nothing _ = nothing "" "" moduleHeadPos
+  where moduleHeadPos = after AnnClose >>= \case loc@(RealSrcLoc _) -> return loc
+                                                 _ -> atTheStart
+
+trfFilePragmas :: RangeAnnot a => Trf (AnnList AST.FilePragma a)
+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 :: RangeAnnot a => Located String -> Trf (Ann AST.FilePragma a)
+trfLanguagePragma lstr@(L l str) = annLoc (pure l) (AST.LanguagePragma <$> makeList ", " (pure $ srcSpanStart $ getLoc $ last pragmaElems) 
+                                                                                         (mapM (trfLoc (pure . AST.LanguageExtension)) extensions))
+  where pragmaElems = splitLocated lstr
+        extensions = init $ drop 2 pragmaElems
+
+trfOptionsPragma :: RangeAnnot a => Located String -> Trf (Ann AST.FilePragma a)
+trfOptionsPragma (L l str) = annLoc (pure l) (AST.OptionsPragma <$> annCont (pure $ AST.StringNode str))
+
+trfModulePragma :: RangeAnnot a => Maybe (Located WarningTxt) -> Trf (AnnMaybe AST.ModulePragma a)
+trfModulePragma = trfMaybeDefault " " "" (trfLoc $ \case WarningTxt _ txts -> AST.ModuleWarningPragma <$> trfAnnList " " trfText' txts
+                                                         DeprecatedTxt _ txts -> AST.ModuleDeprecatedPragma <$> trfAnnList " " trfText' txts) 
+                                  (before AnnWhere)
+
+trfText' :: RangeAnnot a => StringLiteral -> Trf (AST.StringNode a)
+trfText' = pure . AST.StringNode . unpackFS . sl_fs
+
+
+
+trfExportList :: TransformName n r => SrcLoc -> Maybe (Located [LIE n]) -> Trf (AnnMaybe AST.ExportSpecList r)
+trfExportList loc = trfMaybeDefault " " "" (trfLoc trfExportList') (pure loc)
+
+trfExportList' :: TransformName n r => [LIE n] -> Trf (AST.ExportSpecList r)
+trfExportList' exps = AST.ExportSpecList <$> (makeList ", " (after AnnOpenP) (orderDefs . catMaybes <$> (mapM trfExport exps)))
+  
+trfExport :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.ExportSpec r))
+trfExport = trfMaybeLoc $ \case 
+  IEModuleContents n -> Just . AST.ModuleExport <$> (trfModuleName n)
+  other -> do trf <- trfIESpec' other
+              fmap AST.DeclExport <$> (sequence $ fmap (annCont . return) trf)
+
+trfImports :: TransformName n r => [LImportDecl n] -> Trf (AnnList AST.ImportDecl r)
+trfImports (filter (not . ideclImplicit . unLoc) -> imps) 
+  = AnnList <$> importDefaultLoc <*> mapM trfImport imps
+  where importDefaultLoc = toIndentedListAnnot (if Data.List.null imps then "\n" else "") "" "\n" . srcSpanEnd 
+                             <$> (combineSrcSpans <$> asks (srcLocSpan . srcSpanStart . contRange) 
+                                                  <*> (srcLocSpan . srcSpanEnd <$> tokenLoc AnnWhere))
+trfImport :: forall n r . TransformName n r => LImportDecl n -> Trf (Ann AST.ImportDecl r)
+trfImport = (addImportData @r @n <=<) $ trfLoc $ \(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
+      atAsPos = if isJust declHiding then before AnnOpenP else atTheEnd
+  in AST.ImportDecl 
+       <$> (if isSrc then makeJust <$> annLoc (tokensLoc [AnnOpen, AnnClose]) (pure AST.ImportSource)
+                     else nothing " " "" (after AnnImport))
+       <*> (if isQual then makeJust <$> (annLoc (tokenLoc AnnQualified) (pure AST.ImportQualified)) 
+                      else nothing " " "" (after annBeforeQual))
+       <*> (if isSafe then makeJust <$> (annLoc (tokenLoc AnnSafe) (pure AST.ImportSafe)) 
+                      else nothing " " "" (after annBeforeSafe))
+       <*> maybe (nothing " " "" (after annBeforePkg)) 
+                 (\str -> makeJust <$> (annLoc (tokenLoc AnnPackageName) (pure (AST.StringNode (unpackFS $ sl_fs str))))) pkg
+       <*> trfModuleName name 
+       <*> maybe (nothing " " "" atAsPos) (\mn -> makeJust <$> (trfRenaming mn)) declAs
+       <*> trfImportSpecs declHiding
+  where trfRenaming mn
+          = annLoc (tokensLoc [AnnAs,AnnVal])
+                   (AST.ImportRenaming <$> (annLoc (tokenLoc AnnVal) 
+                                           (trfModuleName' mn)))  
+  
+trfImportSpecs :: TransformName n r => Maybe (Bool, Located [LIE n]) -> Trf (AnnMaybe AST.ImportSpec r)
+trfImportSpecs (Just (True, l)) 
+  = makeJust <$> trfLoc (\specs -> AST.ImportSpecHiding <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l
+trfImportSpecs (Just (False, l)) 
+  = makeJust <$> trfLoc (\specs -> AST.ImportSpecList <$> (makeList ", " (after AnnOpenP) (catMaybes <$> mapM trfIESpec specs))) l
+trfImportSpecs Nothing = nothing " " "" atTheEnd
+    
+trfIESpec :: TransformName n r => LIE n -> Trf (Maybe (Ann AST.IESpec r)) 
+trfIESpec = trfMaybeLoc trfIESpec'
+  
+trfIESpec' :: TransformName n r => IE n -> Trf (Maybe (AST.IESpec r))
+trfIESpec' (IEVar n) = Just <$> (AST.IESpec <$> trfName n <*> (nothing "(" ")" atTheEnd))
+trfIESpec' (IEThingAbs n) = Just <$> (AST.IESpec <$> trfName n <*> (nothing "(" ")" atTheEnd))
+trfIESpec' (IEThingAll n) 
+  = Just <$> (AST.IESpec <$> trfName n <*> (makeJust <$> (annLoc (tokenLoc AnnDotdot) (pure AST.SubSpecAll))))
+trfIESpec' (IEThingWith n _ ls _)
+  = Just <$> (AST.IESpec <$> trfName n
+                         <*> (makeJust <$> between AnnOpenP AnnCloseP 
+                                                  (annCont $ AST.SubSpecList <$> makeList ", " (after AnnOpenP) (mapM trfName ls))))
+trfIESpec' _ = pure Nothing
+  
+

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

@@ -0,0 +1,80 @@+-- | 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.Maybe
+
+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
+             , 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.
+             }
+      
+trfInit :: Map ApiAnnKey [SrcSpan] -> Map String [Located String] -> TrfInput
+trfInit annots comments 
+  = TrfInput { srcMap = annotationsToSrcMap annots
+             , pragmaComms = comments
+             , contRange = noSrcSpan
+             , localsInScope = []
+             , defining = False
+             , definingTypeVars = False
+             , originalNames = empty
+             }
+
+-- | 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)

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

@@ -0,0 +1,70 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , ScopedTypeVariables
+           , AllowAmbiguousTypes
+           #-}
+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.Base
+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(..))
+import qualified Language.Haskell.Tools.AST as AST
+
+trfPattern :: TransformName n r => Located (Pat n) -> Trf (Ann AST.Pattern r)
+-- 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 (trfLoc trfPatternField') notWC
+       wildc <- annLoc (tokenLoc AnnDotdot) (pure AST.FieldWildcardPattern)
+       annLoc (pure l) (AST.RecPat <$> trfName name <*> makeNonemptyList ", " (pure (normalFields ++ [wildc])))
+trfPattern p | otherwise = trfLoc 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.Pattern r)
+trfPattern' (WildPat _) = pure AST.WildPat
+trfPattern' (VarPat name) = define $ AST.VarPat <$> trfName name
+trfPattern' (LazyPat pat) = AST.IrrPat <$> trfPattern pat
+trfPattern' (AsPat name pat) = AST.AsPat <$> define (trfName name) <*> trfPattern pat
+trfPattern' (ParPat pat) = AST.ParenPat <$> trfPattern pat
+trfPattern' (BangPat pat) = AST.BangPat <$> trfPattern pat
+trfPattern' (ListPat pats _ _) = AST.ListPat <$> trfAnnList ", " trfPattern' pats
+trfPattern' (TuplePat pats Boxed _) = AST.TuplePat <$> trfAnnList ", " trfPattern' pats
+trfPattern' (PArrPat pats _) = AST.ParArrPat <$> trfAnnList ", " trfPattern' pats
+trfPattern' (ConPatIn name (PrefixCon args)) = AST.AppPat <$> trfName name <*> trfAnnList " " trfPattern' args
+trfPattern' (ConPatIn name (RecCon (HsRecFields flds _))) = AST.RecPat <$> trfName name <*> trfAnnList ", " trfPatternField' flds
+trfPattern' (ConPatIn name (InfixCon left right)) = AST.InfixPat <$> trfPattern left <*> trfOperator name <*> trfPattern right
+trfPattern' (ViewPat expr pat _) = AST.ViewPat <$> trfExpr expr <*> trfPattern pat
+trfPattern' (SplicePat splice) = AST.SplicePat <$> annCont (trfSplice' splice)
+trfPattern' (LitPat lit) = AST.LitPat <$> annCont (trfLiteral' lit)
+trfPattern' (SigPatIn pat (hswc_body . hsib_body -> typ)) = AST.TypeSigPat <$> trfPattern pat <*> trfType typ
+trfPattern' (NPat (ol_val . unLoc -> lit) _ _ _) = AST.LitPat <$> annCont (trfOverloadedLit lit)
+trfPattern' (NPlusKPat id (L l lit) _ _ _ _) = AST.NPlusKPat <$> define (trfName id) <*> annLoc (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.PatternField r)
+trfPatternField' (HsRecField id arg False) = AST.NormalFieldPattern <$> trfName (getFieldOccName id) <*> trfPattern arg
+trfPatternField' (HsRecField id _ True) = AST.FieldPunPattern <$> trfName (getFieldOccName id)

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

@@ -0,0 +1,44 @@+-- | A representation of the tokens that build up the source file.
+module Language.Haskell.Tools.AST.FromGHC.SourceMap where
+
+import ApiAnnotation
+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)
+
+-- | 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 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 srcmap
+
+getKeywordsInside :: AnnKeywordId -> SrcSpan -> SourceMap -> [SrcSpan]
+getKeywordsInside keyw sr srcmap 
+  = maybe [] (List.map (uncurry mkSrcSpan) . assocs . fst . Map.split (srcSpanEnd sr) . snd . Map.split (srcSpanStart sr)) (Map.lookup keyw srcmap)
+
+getKeywordInsideBack :: AnnKeywordId -> SrcSpan -> SourceMap -> Maybe SrcSpan
+getKeywordInsideBack keyw sr srcmap = getSourceElementInside False sr =<< Map.lookup keyw 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
+    
+-- | Converts GHC Annotations into a convenient format for looking up tokens
+annotationsToSrcMap :: Map ApiAnnKey [SrcSpan] -> Map AnnKeywordId (Map SrcLoc SrcLoc)
+annotationsToSrcMap anns = Map.map (List.foldr addToSrcRanges Map.empty) $ mapKeysWith (++) snd anns
+  where 
+    addToSrcRanges :: SrcSpan -> Map SrcLoc SrcLoc -> Map SrcLoc SrcLoc
+    addToSrcRanges span srcmap = Map.insert (srcSpanStart span) (srcSpanEnd span) srcmap
+    
+    
+

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

@@ -0,0 +1,80 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           #-}
+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.Base
+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(..), AnnList(..), AnnMaybe(..))
+import qualified Language.Haskell.Tools.AST as AST
+ 
+trfDoStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf (Ann AST.Stmt r)
+trfDoStmt = trfLoc trfDoStmt'
+
+trfDoStmt' :: TransformName n r => Stmt n (Located (HsExpr n)) -> Trf (AST.Stmt' AST.Expr r)
+trfDoStmt' = gTrfDoStmt' trfExpr
+
+gTrfDoStmt' :: TransformName n r => (Located (ge n) -> Trf (Ann ae r)) -> Stmt n (Located (ge n)) -> Trf (AST.Stmt' ae r)
+gTrfDoStmt' et (BindStmt pat expr _ _ _) = AST.BindStmt <$> trfPattern pat <*> et expr
+gTrfDoStmt' et (BodyStmt expr _ _ _) = AST.ExprStmt <$> et expr
+gTrfDoStmt' et (LetStmt (unLoc -> binds)) = AST.LetStmt <$> addToScope binds (trfLocalBinds binds)
+gTrfDoStmt' et (LastStmt body _ _) = AST.ExprStmt <$> et body
+gTrfDoStmt' et (RecStmt { recS_stmts = stmts }) = AST.RecStmt <$> trfAnnList "," (gTrfDoStmt' et) stmts
+
+trfListCompStmts :: TransformName n r => [Located (Stmt n (LHsExpr n))] -> Trf (AnnList AST.ListCompBody r)
+trfListCompStmts [unLoc -> ParStmt blocks _ _ _, unLoc -> (LastStmt {})]
+  = nonemptyAnnList
+      <$> trfScopedSequence (\(ParStmtBlock stmts _ _) -> 
+                                let ann = toNodeAnnot $ collectLocs $ getNormalStmts stmts
+                                 in Ann ann . AST.ListCompBody . AnnList ann . concat 
+                                      <$> trfScopedSequence trfListCompStmt stmts
+                            ) blocks
+trfListCompStmts others 
+  = let ann = (collectLocs $ getNormalStmts others)
+     in AnnList (toNodeAnnot ann) . (:[]) 
+          <$> annLoc (pure ann)
+                     (AST.ListCompBody . AnnList (toNodeAnnot ann) . concat <$> trfScopedSequence trfListCompStmt others) 
+
+trfListCompStmt :: TransformName n r => Located (Stmt n (LHsExpr n)) -> Trf [Ann AST.CompStmt r]
+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.CompStmt (trfDoStmt other)
+  
+extractActualStmt :: TransformName n r => Stmt n (LHsExpr n) -> Trf (Ann AST.CompStmt r)
+extractActualStmt = \case
+  TransStmt { trS_form = ThenForm, trS_using = using, trS_by = by } 
+    -> addAnnotation by using (AST.ThenStmt <$> trfExpr using <*> trfMaybe "," "" trfExpr by)
+  TransStmt { trS_form = GroupForm, trS_using = using, trS_by = by } 
+    -> addAnnotation by using (AST.GroupStmt <$> trfMaybe "," "" trfExpr by <*> (makeJust <$> trfExpr using))
+  where addAnnotation by using
+          = annLoc (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,42 @@+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 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.Base
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+
+import qualified Language.Haskell.Tools.AST as AST
+
+trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.QuasiQuote r)
+ -- the lexer does not provide us with tokens '[', '|' and '|]'
+trfQuasiQuotation' (HsQuasiQuote id _ l str) 
+  = AST.QuasiQuote <$> annLoc (pure quoterLoc) (trfName' id)
+                   <*> annLoc (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 => HsSplice n -> Trf (AST.Splice r)
+trfSplice' (HsTypedSplice _ expr) = AST.ParenSplice <$> trfExpr expr
+trfBracket' :: TransformName n r => HsBracket n -> Trf (AST.Bracket r)
+trfBracket' (ExpBr expr) = AST.ExprBracket <$> trfExpr expr
+trfBracket' (TExpBr expr) = AST.ExprBracket <$> trfExpr expr
+trfBracket' (VarBr _ expr) = AST.ExprBracket <$> annCont (AST.Var <$> (annCont (trfName' expr)))
+trfBracket' (PatBr pat) = AST.PatternBracket <$> trfPattern pat
+trfBracket' (DecBrL decls) = AST.DeclsBracket <$> trfDecls decls
+trfBracket' (DecBrG decls) = AST.DeclsBracket <$> trfDeclsGroup decls
+trfBracket' (TypBr typ) = AST.TypeBracket <$> trfType typ

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

@@ -0,0 +1,15 @@+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.Base
+import Language.Haskell.Tools.AST (Ann(..))
+import qualified Language.Haskell.Tools.AST as AST
+
+trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.QuasiQuote r)
+trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.Splice r)
+trfBracket' :: TransformName n r => HsBracket n -> Trf (AST.Bracket r)

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

@@ -0,0 +1,111 @@+{-# LANGUAGE LambdaCase
+           , ViewPatterns
+           , ScopedTypeVariables
+           #-}
+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.Data (Data(..), toConstr)
+
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+import Language.Haskell.Tools.AST.FromGHC.Base
+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.Type r)
+trfType = trfLoc trfType'
+
+trfType' :: TransformName n r => HsType n -> Trf (AST.Type r)
+trfType' = trfType'' . cleanHsType where
+  trfType'' (HsForAllTy [] typ) = trfType' (unLoc typ)
+  trfType'' (HsForAllTy bndrs typ) = AST.TyForall <$> defineTypeVars (trfBindings bndrs) 
+                                                  <*> addToScope bndrs (trfType typ)
+  trfType'' (HsQualTy ctx typ) = AST.TyCtx <$> (fromJust . (^. annMaybe) <$> trfCtx atTheStart ctx) 
+                                           <*> trfType typ
+  trfType'' (HsTyVar name) = AST.TyVar <$> transformingPossibleVar name (trfName name)
+  trfType'' (HsAppsTy apps) | Just (head, args) <- getAppsTyHead_maybe apps 
+    = foldl (\core t -> AST.TyApp <$> annLoc (pure $ getLoc head `combineSrcSpans` getLoc t) core <*> trfType t) (trfType' (unLoc head)) args
+  trfType'' (HsAppTy t1 t2) = AST.TyApp <$> trfType t1 <*> trfType t2
+  trfType'' (HsFunTy t1 t2) = AST.TyFun <$> trfType t1 <*> trfType t2
+  trfType'' (HsListTy typ) = AST.TyList <$> trfType typ
+  trfType'' (HsPArrTy typ) = AST.TyParArray <$> trfType typ
+  trfType'' (HsTupleTy HsBoxedOrConstraintTuple typs) = AST.TyTuple <$> trfAnnList ", " trfType' typs
+  trfType'' (HsTupleTy HsBoxedTuple typs) = AST.TyTuple <$> trfAnnList ", " trfType' typs
+  trfType'' (HsTupleTy HsUnboxedTuple typs) = AST.TyUnbTuple <$> trfAnnList ", " trfType' typs
+  trfType'' (HsOpTy t1 op t2) = AST.TyInfix <$> trfType t1 <*> trfOperator op <*> trfType t2
+  trfType'' (HsParTy typ) = AST.TyParen <$> trfType typ
+  trfType'' (HsKindSig typ kind) = AST.TyKinded <$> trfType typ <*> trfKind kind
+  trfType'' (HsSpliceTy splice _) = AST.TySplice <$> trfSplice' splice
+  trfType'' (HsBangTy (HsSrcBang _ SrcUnpack _) typ) = AST.TyUnpack <$> trfType typ
+  trfType'' (HsBangTy (HsSrcBang _ SrcNoUnpack _) typ) = AST.TyNoUnpack <$> trfType typ
+  trfType'' (HsBangTy (HsSrcBang _ _ SrcStrict) typ) = AST.TyBang <$> trfType typ
+  trfType'' (HsBangTy (HsSrcBang _ _ SrcLazy) typ) = AST.TyLazy <$> trfType typ
+  trfType'' pt@(HsExplicitListTy {}) = AST.TyPromoted <$> annCont (trfPromoted' trfType' pt) 
+  trfType'' pt@(HsExplicitTupleTy {}) = AST.TyPromoted <$> annCont (trfPromoted' trfType' pt) 
+  trfType'' pt@(HsTyLit {}) = AST.TyPromoted <$> annCont (trfPromoted' trfType' pt) 
+  trfType'' (HsWildCardTy _) = pure AST.TyWildcard -- TODO: named wildcards
+  trfType'' t = error ("Illegal type: " ++ showSDocUnsafe (ppr t) ++ " (ctor: " ++ show (toConstr t) ++ ")")
+  
+trfBindings :: TransformName n r => [Located (HsTyVarBndr n)] -> Trf (AnnList AST.TyVar r)
+trfBindings vars = trfAnnList "\n" trfTyVar' vars
+  
+trfTyVar :: TransformName n r => Located (HsTyVarBndr n) -> Trf (Ann AST.TyVar r)
+trfTyVar = trfLoc trfTyVar' 
+  
+trfTyVar' :: TransformName n r => HsTyVarBndr n -> Trf (AST.TyVar r)
+trfTyVar' (UserTyVar name) = AST.TyVarDecl <$> typeVarTransform (trfName name)
+                                           <*> (nothing " " "" atTheEnd)
+trfTyVar' (KindedTyVar name kind) = AST.TyVarDecl <$> typeVarTransform (trfName name) 
+                                                  <*> trfKindSig (Just kind)
+  
+trfCtx :: TransformName n r => Trf SrcLoc -> Located (HsContext n) -> Trf (AnnMaybe AST.Context r)
+trfCtx sp (L l []) = nothing " " "" sp
+trfCtx _ (L l [L _ (HsParTy t)]) 
+  = makeJust <$> annLoc (combineSrcSpans l <$> tokenLoc AnnDarrow) 
+                        (AST.ContextMulti <$> trfAnnList ", " trfAssertion' [t])
+trfCtx _ (L l [t]) 
+  = makeJust <$> annLoc (combineSrcSpans l <$> tokenLoc AnnDarrow) 
+                        (AST.ContextOne <$> trfAssertion t)
+trfCtx _ (L l ctx) = makeJust <$> annLoc (combineSrcSpans l <$> tokenLoc AnnDarrow) 
+                                         (AST.ContextMulti <$> trfAnnList ", " trfAssertion' ctx) 
+  
+trfAssertion :: TransformName n r => LHsType n -> Trf (Ann AST.Assertion r)
+trfAssertion = trfLoc trfAssertion'
+
+trfAssertion' :: forall n r . TransformName n r => HsType n -> Trf (AST.Assertion r)
+trfAssertion' (cleanHsType -> HsParTy t) 
+  = trfAssertion' (unLoc t)
+trfAssertion' (cleanHsType -> HsOpTy left op right) 
+  = AST.InfixAssert <$> trfType left <*> trfOperator op <*> trfType right
+trfAssertion' (cleanHsType -> t) = case cleanHsType base of
+   HsTyVar name -> AST.ClassAssert <$> trfName name <*> trfAnnList " " trfType' args
+   HsEqTy t1 t2 -> AST.InfixAssert <$> trfType t1 <*> annLoc (tokenLoc AnnTilde) (trfOperator' typeEq) <*> trfType t2
+   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,342 @@+-- | Utility functions for transforming the GHC AST representation into our own.
+{-# LANGUAGE TypeSynonymInstances 
+           , FlexibleInstances
+           , LambdaCase
+           , ViewPatterns
+           , MultiParamTypeClasses
+           , FlexibleContexts
+           , AllowAmbiguousTypes
+           #-}
+module Language.Haskell.Tools.AST.FromGHC.Utils where
+
+import ApiAnnotation
+import SrcLoc
+import GHC
+import Avail
+import HscTypes
+import HsSyn
+import Module
+import Name
+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.FromGHC.Monad
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
+import Language.Haskell.Tools.AST.FromGHC.SourceMap
+import Debug.Trace
+
+-- | Annotations that is made up from ranges
+class HasRange annot => RangeAnnot annot where
+  toNodeAnnot :: SrcSpan -> annot
+  toListAnnot :: String -> String -> String -> SrcLoc -> annot
+  toIndentedListAnnot :: String -> String -> String -> SrcLoc -> annot
+  toOptAnnot :: String -> String -> SrcLoc -> annot
+
+instance RangeAnnot (NodeInfo (SemanticInfo n) SpanInfo) where
+  toNodeAnnot = NodeInfo NoSemanticInfo . NodeSpan
+  toListAnnot bef aft sep = NodeInfo NoSemanticInfo . ListPos bef aft sep False
+  toIndentedListAnnot bef aft sep = NodeInfo NoSemanticInfo . ListPos bef aft sep True
+  toOptAnnot bef aft = NodeInfo NoSemanticInfo . OptionalPos bef aft
+
+-- | Annotations that carry semantic information
+class SemanticAnnot annot n where
+  addSemanticInfo :: SemanticInfo n -> annot -> annot
+  addScopeData :: annot -> Trf annot
+  addImportData :: Ann AST.ImportDecl annot -> Trf (Ann AST.ImportDecl annot)
+  
+instance SemanticAnnot RangeWithName GHC.Name where
+  addSemanticInfo si = semanticInfo .= si
+  addScopeData = semanticInfo !~ (\case NoSemanticInfo -> do locals <- asks localsInScope
+                                                             return $ ScopeInfo locals
+                                        inf -> return inf)
+  addImportData = addImportData'
+
+instance {-# OVERLAPPING #-} SemanticAnnot RangeInfo RdrName where
+  addSemanticInfo si = semanticInfo .= si
+  addScopeData = semanticInfo !~ (\case NoSemanticInfo -> do locals <- asks localsInScope
+                                                             return $ ScopeInfo locals
+                                        inf -> return inf)
+  addImportData = pure
+
+instance {-# OVERLAPPABLE #-} SemanticAnnot RangeInfo n where
+  addSemanticInfo si = id
+  addScopeData = pure
+  addImportData = pure
+  
+-- | Adds semantic information to an impord declaration. See ImportInfo.
+addImportData' :: Ann AST.ImportDecl RangeWithName -> Trf (Ann AST.ImportDecl RangeWithName)
+addImportData' imp = 
+  do (mod,importedNames) <- getImportedNames (nameString $ imp ^. element&importModule&element)
+                                             (imp ^? element&importPkg&annJust&element&stringNodeStr)
+     names <- lift $ filterM (checkImportVisible (imp ^. element)) importedNames
+     return $ annotation .- addSemanticInfo (ImportInfo mod importedNames names) $ imp
+
+-- | Get names that are imported from a given import
+getImportedNames :: String -> Maybe String -> Trf (GHC.Module, [GHC.Name])
+getImportedNames name pkg = lift $ 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 :: GhcMonad m => AST.ImportDecl RangeWithName -> GHC.Name -> m Bool
+checkImportVisible imp name
+  | importIsExact imp 
+  = or <$> mapM (`ieSpecMatches` name) (imp ^? importExacts :: [IESpec RangeWithName])
+  | importIsHiding imp 
+  = not . or <$> mapM (`ieSpecMatches` name) (imp ^? importHidings :: [IESpec RangeWithName])
+  | otherwise = return True
+
+ieSpecMatches :: GhcMonad m => AST.IESpec RangeWithName -> GHC.Name -> m Bool
+ieSpecMatches (AST.IESpec ((^? element&simpleName&annotation&semanticInfo&nameInfo) -> Just n) ss) name
+  | n == name = return True
+  | isTyConName n
+  = (\case Just (ATyCon tc) -> name `elem` map getName (tyConDataCons tc)) 
+             <$> lookupName n
+  | otherwise = return False
+
+
+-- | Creates a place for a missing node with a default location
+nothing :: RangeAnnot a => String -> String -> Trf SrcLoc -> Trf (AnnMaybe e a)
+nothing bef aft pos = annNothing . toOptAnnot bef aft <$> pos 
+
+emptyList :: RangeAnnot a => String -> Trf SrcLoc -> Trf (AnnList e a)
+emptyList sep ann = AnnList <$> (toListAnnot "" "" sep <$> ann) <*> pure []
+
+-- | Creates a place for a list of nodes with a default place if the list is empty.
+makeList :: RangeAnnot a => String -> Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a)
+makeList sep ann ls = AnnList <$> (toListAnnot "" "" sep <$> ann) <*> ls
+
+makeListBefore :: RangeAnnot a => String -> String -> Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a)
+makeListBefore bef sep ann ls = do isEmpty <- null <$> ls 
+                                   AnnList <$> (toListAnnot (if isEmpty then bef else "") "" sep <$> ann) <*> ls
+
+makeListAfter :: RangeAnnot a => String -> String -> Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a)
+makeListAfter aft sep ann ls = do isEmpty <- null <$> ls 
+                                  AnnList <$> (toListAnnot "" (if isEmpty then aft else "") sep <$> ann) <*> ls
+
+makeNonemptyList :: RangeAnnot a => String -> Trf [Ann e a] -> Trf (AnnList e a)
+makeNonemptyList sep ls = AnnList (toListAnnot "" "" sep noSrcLoc) <$> ls
+
+-- | Creates a place for an indented list of nodes with a default place if the list is empty.
+makeIndentedList :: RangeAnnot a => Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a)
+makeIndentedList ann ls = AnnList <$> (toIndentedListAnnot "" "" "\n" <$> ann) <*> ls
+
+makeIndentedListNewlineBefore :: RangeAnnot a => Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a)
+makeIndentedListNewlineBefore ann ls = do isEmpty <- null <$> ls 
+                                          AnnList <$> (toIndentedListAnnot (if isEmpty then "\n" else "") "" "\n" <$> ann) <*> ls
+
+makeIndentedListBefore :: RangeAnnot a => String -> Trf SrcLoc -> Trf [Ann e a] -> Trf (AnnList e a)
+makeIndentedListBefore bef sp ls = do isEmpty <- null <$> ls 
+                                      AnnList <$> (toIndentedListAnnot (if isEmpty then bef else "") "" "\n" <$> sp) <*> ls
+  
+makeNonemptyIndentedList :: RangeAnnot a => Trf [Ann e a] -> Trf (AnnList e a)
+makeNonemptyIndentedList ls = AnnList (toIndentedListAnnot "" "" "\n" noSrcLoc) <$> ls
+  
+-- | Transform a located part of the AST by automatically transforming the location.
+-- Sets the source range for transforming children.
+trfLoc :: RangeAnnot i => (a -> Trf (b i)) -> Located a -> Trf (Ann b i)
+trfLoc = trfLocCorrect pure
+
+-- | Transforms a possibly-missing node with the default location of the end of the focus.
+trfMaybe :: RangeAnnot i => String -> String -> (Located a -> Trf (Ann e i)) -> Maybe (Located a) -> Trf (AnnMaybe e i)
+trfMaybe bef aft f = trfMaybeDefault bef aft f atTheEnd
+
+-- | Transforms a possibly-missing node with a default location
+trfMaybeDefault :: RangeAnnot i => String -> String -> (Located a -> Trf (Ann e i)) -> Trf SrcLoc -> Maybe (Located a) -> Trf (AnnMaybe e i)
+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 :: RangeAnnot i => (SrcSpan -> Trf SrcSpan) -> (a -> Trf (b i)) -> Located a -> Trf (Ann b i)
+trfLocCorrect locF f (L l e) = annLoc (locF l) (f e)
+
+-- | Transform a located part of the AST by automatically transforming the location.
+-- Sets the source range for transforming children.
+trfMaybeLoc :: RangeAnnot i => (a -> Trf (Maybe (b i))) -> Located a -> Trf (Maybe (Ann b i))
+trfMaybeLoc f (L l e) = do fmap (Ann (toNodeAnnot l)) <$> local (\s -> s { contRange = l }) (f e)
+
+-- | Creates a place for a list of nodes with the default place at the end of the focus if the list is empty.
+trfAnnList :: RangeAnnot i => String -> (a -> Trf (b i)) -> [Located a] -> Trf (AnnList b i)
+trfAnnList sep _ [] = makeList sep atTheEnd (pure [])
+trfAnnList sep f ls = makeList sep (pure $ noSrcLoc) (mapM (trfLoc f) ls)
+
+trfAnnList' :: RangeAnnot i => String -> (Located a -> Trf (Ann b i)) -> [Located a] -> Trf (AnnList b i)
+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 :: RangeAnnot i => [Ann e i] -> AnnList e i
+nonemptyAnnList = AnnList (toListAnnot "" "" "" noSrcLoc)
+
+-- | Creates an optional node from an existing element
+makeJust :: RangeAnnot a => Ann e a -> AnnMaybe e a
+makeJust e = AnnMaybe (toOptAnnot "" "" noSrcLoc) (Just e)
+
+-- | Annotates a node with the given location and focuses on the given source span.
+annLoc :: RangeAnnot a => Trf SrcSpan -> Trf (b a) -> Trf (Ann b a)
+annLoc locm nodem = do loc <- locm
+                       node <- focusOn loc nodem
+                       return (Ann (toNodeAnnot loc) node)
+
+-- * Focus manipulation
+
+focusOn :: SrcSpan -> Trf a -> Trf a
+focusOn sp = local (\s -> s { contRange = sp })
+
+-- | 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 after 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 :: RangeAnnot a => AnnKeywordId -> Trf (e a) -> Trf (Ann e a)
+annFrom kw = annLoc (combineSrcSpans <$> tokenLoc kw <*> asks (srcLocSpan . srcSpanEnd . contRange))
+
+-- | 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)
+
+-- | 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 :: RangeAnnot a => Trf (e a) -> Trf (Ann e a)
+annCont = annLoc (asks contRange)
+
+-- | Annotates the element with the same annotation that is on the other element
+copyAnnot :: (Ann a i -> b i) -> Trf (Ann a i) -> Trf (Ann b i)
+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)
+
+-- | 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 :: RangeAnnot i => [Ann e i] -> [Ann e i]
+orderDefs = sortBy (compare `on` AST.ordSrcSpan . getRange . _annotation)
+
+-- | Orders a list of elements to the order they are defined in the source file.
+orderAnnList :: RangeAnnot i => AnnList e i -> AnnList e i
+orderAnnList (AnnList a ls) = AnnList 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-ast-fromghc.cabal view

@@ -0,0 +1,44 @@+name:                haskell-tools-ast-fromghc
+version:             0.1.2.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 
+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.GHCUtils                  
+  other-modules:       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.Base
+                     , Language.Haskell.Tools.AST.FromGHC.Monad
+                     , Language.Haskell.Tools.AST.FromGHC.Utils
+                     , Language.Haskell.Tools.AST.FromGHC.SourceMap
+
+  build-depends:       base              >=4.9 && <5.0
+                     , ghc               >=8.0 && <8.1
+                     , haskell-tools-ast >=0.1 && <0.2
+                     , references        >=0.3.2 && <1.0
+                     , bytestring        >=0.10 && <1.0
+                     , safe              >=0.3
+                     , uniplate          >=1.6  && <2.0
+                     , containers        >=0.5 && <0.6
+                     , mtl               >=2.2 && <2.3
+                     , split             >=0.2 && <0.3
+                     , structural-traversal >=0.1 && <0.2
+                     , template-haskell  >=2.11 && <3.0
+  default-language:    Haskell2010