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)
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)
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)
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
advanceAllSrcLoc :: SrcLoc -> String -> SrcLoc
advanceAllSrcLoc (RealSrcLoc rl) str = RealSrcLoc $ foldl advanceSrcLoc rl str
advanceAllSrcLoc oth _ = oth
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' 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)