module Language.Haskell.Tools.AST.FromGHC.Names where
import Control.Monad.Reader ((=<<), asks)
import Data.Char (isDigit, isLetter)
import FastString as GHC (FastString, unpackFS)
import HsSyn as GHC
import Name as GHC (isSymOcc)
import qualified Name as GHC (Name)
import RdrName as GHC (RdrName)
import SrcLoc as GHC
import Language.Haskell.Tools.AST (Ann(..), AnnListG, RangeStage, Dom)
import qualified Language.Haskell.Tools.AST as AST
import Language.Haskell.Tools.AST.FromGHC.GHCUtils
import Language.Haskell.Tools.AST.FromGHC.Monad (TrfInput(..), Trf, getOriginalName)
import Language.Haskell.Tools.AST.FromGHC.Utils
trfOperator :: TransformName n r => Located n -> Trf (Ann AST.UOperator (Dom r) RangeStage)
trfOperator = trfLocNoSema trfOperator'
trfOperator' :: TransformName n r => n -> Trf (AST.UOperator (Dom r) RangeStage)
trfOperator' n
| isSymOcc (occName n) = AST.UNormalOp <$> (annCont (createNameInfo (transformName n)) (trfQualifiedName' n))
| otherwise = AST.UBacktickOp <$> (annLoc (createNameInfo (transformName n)) loc (trfQualifiedName' n))
where loc = mkSrcSpan <$> (updateCol (+1) <$> atTheStart) <*> (updateCol (subtract 1) <$> atTheEnd)
trfName :: TransformName n r => Located n -> Trf (Ann AST.UName (Dom r) RangeStage)
trfName = trfLocNoSema trfName'
trfName' :: TransformName n r => n -> Trf (AST.UName (Dom r) RangeStage)
trfName' n
| isSymOcc (occName n) = AST.UParenName <$> (annLoc (createNameInfo (transformName n)) loc (trfQualifiedName' n))
| otherwise = AST.UNormalName <$> (annCont (createNameInfo (transformName n)) (trfQualifiedName' n))
where loc = mkSrcSpan <$> (updateCol (+1) <$> atTheStart) <*> (updateCol (subtract 1) <$> atTheEnd)
trfAmbiguousFieldName :: TransformName n r => Located (AmbiguousFieldOcc n) -> Trf (Ann AST.UName (Dom r) RangeStage)
trfAmbiguousFieldName (L l af) = trfAmbiguousFieldName' l af
trfAmbiguousFieldName' :: forall n r . TransformName n r => SrcSpan -> AmbiguousFieldOcc n -> Trf (Ann AST.UName (Dom r) RangeStage)
trfAmbiguousFieldName' l (Unambiguous (L _ rdr) pr) = annLocNoSema (pure l) $ trfName' (unpackPostRn @n rdr pr)
trfAmbiguousFieldName' _ (Ambiguous (L l rdr) _)
= annLocNoSema (pure l)
$ AST.UNormalName
<$> (annLoc (createAmbigousNameInfo rdr l) (pure l) $ AST.nameFromList <$> trfNameStr (rdrNameStr rdr))
class (DataId n, Eq n, GHCName n) => TransformableName n where
correctNameString :: n -> Trf String
getDeclSplices :: Trf [Located (HsSplice n)]
fromGHCName :: GHC.Name -> n
instance TransformableName RdrName where
correctNameString = pure . rdrNameStr
getDeclSplices = pure []
fromGHCName = rdrName
instance TransformableName GHC.Name where
correctNameString n = getOriginalName (rdrName n)
getDeclSplices = asks declSplices
fromGHCName = id
class (TransformableName name, HsHasName name, TransformableName res, HsHasName res, GHCName res)
=> TransformName name res where
transformName :: name -> res
instance (n ~ r, TransformableName n, HsHasName n) => TransformName n r where
transformName = id
instance (TransformableName res, GHCName res, HsHasName res) => TransformName GHC.Name 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 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 nstr))
trfQualifiedName :: TransformName n r => Located n -> Trf (Ann AST.UQualifiedName (Dom r) RangeStage)
trfQualifiedName (L l n) = annLoc (createNameInfo (transformName n)) (pure l) (trfQualifiedName' n)
trfQualifiedName' :: TransformName n r => n -> Trf (AST.UQualifiedName (Dom r) RangeStage)
trfQualifiedName' n = AST.nameFromList <$> (trfNameStr =<< correctNameString n)
trfNameStr :: String -> Trf (AnnListG AST.UNamePart (Dom r) RangeStage)
trfNameStr str = makeList "." atTheStart (trfNameStr' str <$> atTheStart)
trfNameStr' :: String -> SrcLoc -> [Ann AST.UNamePart (Dom r) RangeStage]
trfNameStr' str srcLoc = fst $
foldl (\(r,loc) np -> let nextLoc = advanceAllSrcLoc loc np
in ( r ++ [Ann (noSemaInfo $ AST.NodeSpan (mkSrcSpan loc nextLoc)) (AST.UNamePart np)], advanceAllSrcLoc nextLoc "." ) )
([], srcLoc) (nameParts str)
where
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
trfFastString :: Located FastString -> Trf (Ann AST.UStringNode (Dom r) RangeStage)
trfFastString = trfLocNoSema $ pure . AST.UStringNode . unpackFS