{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Haskell.Tools.BackendGHC.Names where
import Control.Monad.Reader ((=<<), asks)
import Data.Char (isAlphaNum)
import Data.List.Split (splitOn)
import FastString as GHC (FastString, unpackFS)
import HsSyn as GHC
import Name as GHC (isSymOcc, occNameString)
import qualified Name as GHC (Name)
import OccName as GHC (HasOccName)
import RdrName as GHC (RdrName)
import SrcLoc as GHC
import qualified Id as GHC (Id)
import Language.Haskell.Tools.AST (Ann(..), AnnListG, RangeStage, Dom)
import qualified Language.Haskell.Tools.AST as AST
import Language.Haskell.Tools.BackendGHC.GHCUtils
import Language.Haskell.Tools.BackendGHC.Monad
import Language.Haskell.Tools.BackendGHC.Utils
trfOperator :: forall n r . TransformName n r => Located (IdP n) -> Trf (Ann AST.UOperator (Dom r) RangeStage)
trfOperator = trfLocNoSema (trfOperator' @n)
trfOperator' :: forall n r . TransformName n r => IdP n -> Trf (AST.UOperator (Dom r) RangeStage)
trfOperator' n
| isSymOcc (occName @n n) = AST.UNormalOp <$> (trfQualifiedNameFocus @n) True n
| otherwise = AST.UBacktickOp <$> (trfQualifiedNameFocus @n) True n
trfName :: forall n r . TransformName n r => Located (IdP n) -> Trf (Ann AST.UName (Dom r) RangeStage)
trfName = trfLocNoSema (trfName' @n)
trfName' :: forall n r . TransformName n r => IdP n -> Trf (AST.UName (Dom r) RangeStage)
trfName' n
| isSymOcc (occName @n n) = (if isSpecKind then AST.UNormalName else AST.UParenName) <$> (trfQualifiedNameFocus @n) isSpecKind n
| otherwise = AST.UNormalName <$> (trfQualifiedNameFocus @n) False n
where
isSpecKind = occNameString (occName @n n) `elem` ["*", "#", "?", "??"]
trfAmbiguousFieldName :: TransformName n r => Located (AmbiguousFieldOcc n) -> Trf (Ann AST.UName (Dom r) RangeStage)
trfAmbiguousFieldName (L l af) = trfAmbiguousFieldName' l af
trfAmbiguousFieldName' :: forall n r . TransformName n r => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.UName (Dom r) RangeStage)
trfAmbiguousFieldName' l (Unambiguous (L _ rdr) pr) = annLocNoSema (pure l) $ trfName' @n (unpackPostRn @n rdr pr)
trfAmbiguousFieldName' _ (Ambiguous (L l rdr) _)
= annLocNoSema (pure l)
$ (if (isSymOcc (occName @GhcPs rdr)) then AST.UParenName else AST.UNormalName)
<$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfNameStr (isSymOcc (occName @GhcPs rdr)) (rdrNameStr rdr))
trfAmbiguousOperator' :: forall n r . TransformName n r => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.UOperator (Dom r) RangeStage)
trfAmbiguousOperator' l (Unambiguous (L _ rdr) pr) = annLocNoSema (pure l) $ trfOperator' @n (unpackPostRn @n rdr pr)
trfAmbiguousOperator' _ (Ambiguous (L l rdr) _)
= annLocNoSema (pure l)
$ (if (isSymOcc (occName @GhcPs rdr)) then AST.UNormalOp else AST.UBacktickOp)
<$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfOperatorStr (not $ isSymOcc (occName @GhcPs rdr)) (rdrNameStr rdr))
class (DataId n, Eq n, GHCName n, FromGHCName (IdP n), NameOrRdrName (IdP n) ~ IdP n, HasOccName (IdP n), SourceTextX n)
=> TransformableName n where
correctNameString :: IdP n -> Trf String
transformSplice :: HsSplice GhcPs -> Trf (HsSplice n)
instance TransformableName GhcPs where
correctNameString = pure . rdrNameStr
transformSplice = pure
instance TransformableName GhcRn where
correctNameString n = getOriginalName (rdrName @GhcRn n)
transformSplice = rdrSplice
class (TransformableName name, HsHasName (IdP name), FromGHCName (IdP res), Eq (IdP name) , GHCName res, NameOrRdrName (IdP name) ~ (IdP name))
=> TransformName name res where
transformName :: IdP name -> IdP res
instance TransformName GhcPs GhcPs where transformName = id
instance {-# OVERLAPPABLE #-} (FromGHCName (IdP res), GHCName res) => TransformName GhcRn res where
transformName = fromGHCName
trfNameText :: String -> Trf (Ann AST.UName (Dom r) RangeStage)
trfNameText str
= annContNoSema (AST.UNormalName <$> annLoc (createImplicitNameInfo str) (asks contRange) (AST.nameFromList <$> trfNameStr (isOperatorStr str) str))
trfImplicitName :: HsIPName -> Trf (Ann AST.UName (Dom r) RangeStage)
trfImplicitName (HsIPName fs)
= let nstr = unpackFS fs
in do rng <- asks contRange
let rng' = mkSrcSpan (updateCol (+1) (srcSpanStart rng)) (srcSpanEnd rng)
annContNoSema (AST.UImplicitName <$> annLoc (createImplicitNameInfo nstr) (pure rng')
(AST.nameFromList <$> trfNameStr (isOperatorStr nstr) nstr))
isOperatorStr :: String -> Bool
isOperatorStr = any (not . isAlphaNum)
trfQualifiedName :: forall n r . TransformName n r => Bool -> Located (IdP n) -> Trf (Ann AST.UQualifiedName (Dom r) RangeStage)
trfQualifiedName isOperator (L l n) = focusOn l $ (trfQualifiedNameFocus @n) isOperator n
trfQualifiedNameFocus :: forall n r . TransformName n r => Bool -> IdP n -> Trf (Ann AST.UQualifiedName (Dom r) RangeStage)
trfQualifiedNameFocus isOperator n
= do rng <- asks contRange
let rng' = if isOperator == isSymOcc (occName @n n) then rng
else mkSrcSpan (updateCol (+1) (srcSpanStart rng)) (updateCol (subtract 1) (srcSpanEnd rng))
annLoc (createNameInfo (transformName @n @r n)) (pure rng') (trfQualifiedName' @n n)
trfQualifiedName' :: forall n r . TransformName n r => IdP n -> Trf (AST.UQualifiedName (Dom r) RangeStage)
trfQualifiedName' n = AST.nameFromList <$> ((if isSymOcc (occName @n n) then trfOperatorStr else trfNameStr) False =<< (correctNameString @n) n)
trfOperatorStr :: Bool -> String -> Trf (AnnListG AST.UNamePart (Dom r) RangeStage)
trfOperatorStr isInParen str = do rng <- correctSpan <$> asks contRange
makeList "." (pure $ srcSpanStart rng)
(pure [Ann (noSemaInfo $ AST.NodeSpan rng) (AST.UNamePart str)])
where correctSpan sp = if isInParen then mkSrcSpan (updateCol (+1) (srcSpanStart sp))
(updateCol (subtract 1) (srcSpanEnd sp))
else sp
trfNameStr :: Bool -> String -> Trf (AnnListG AST.UNamePart (Dom r) RangeStage)
trfNameStr isInBackticks str = makeList "." atTheStart (trfNameStr' str . correct <$> atTheStart)
where correct = if isInBackticks then updateCol (+1) else id
trfNameStr' :: String -> SrcLoc -> [Ann AST.UNamePart (Dom r) RangeStage]
trfNameStr' str startLoc = fst $
foldl (\(r,loc) np -> let nextLoc = advanceAllSrcLoc loc np
in ( r ++ [Ann (noSemaInfo $ AST.NodeSpan (mkSrcSpan loc nextLoc)) (AST.UNamePart np)], advanceAllSrcLoc nextLoc "." ) )
([], startLoc) (splitOn "." str)
where
advanceAllSrcLoc :: SrcLoc -> String -> SrcLoc
advanceAllSrcLoc (RealSrcLoc rl) str = RealSrcLoc $ foldl advanceSrcLoc rl str
advanceAllSrcLoc oth _ = oth
trfFastString :: Located FastString -> Trf (Ann AST.UStringNode (Dom r) RangeStage)
trfFastString = trfLocNoSema $ pure . AST.UStringNode . unpackFS