1- {-# LANGUAGE DeriveGeneric #-}
2- {-# LANGUAGE DerivingVia #-}
3- {-# LANGUAGE FlexibleInstances #-}
4- {-# LANGUAGE RankNTypes #-}
1+ {-# LANGUAGE DeriveDataTypeable #-}
2+ {-# LANGUAGE DeriveGeneric #-}
3+ {-# LANGUAGE FlexibleInstances #-}
4+ {-# LANGUAGE RankNTypes #-}
55module Ide.Plugin.Literals (
66 collectLiterals
77 , Literal (.. )
88 , getSrcText
99 , getSrcSpan
1010) where
1111
12- import Data.Set (Set )
13- import qualified Data.Set as S
12+ import Data.Maybe (maybeToList )
1413import Data.Text (Text )
1514import qualified Data.Text as T
1615import Development.IDE.GHC.Compat hiding (getSrcSpan )
1716import Development.IDE.GHC.Util (unsafePrintSDoc )
1817import Development.IDE.Graph.Classes (NFData (rnf ))
1918import qualified GHC.Generics as GHC
20- import Generics.SYB (Data , Typeable , cast ,
21- everything )
19+ import Generics.SYB (Data , Typeable , everything ,
20+ extQ )
2221
2322-- data type to capture what type of literal we are dealing with
2423-- provides location and possibly source text (for OverLits) as well as it's value
2524-- we currently don't have any use for PrimLiterals. They never have source text so we always drop them
2625-- | Captures a Numeric Literals Location, Source Text, and Value.
27- data Literal = IntLiteral RealSrcSpan Text Integer
28- | FracLiteral RealSrcSpan Text Rational
29- deriving (GHC.Generic , Show , Ord , Eq )
26+ data Literal = IntLiteral RealSrcSpan Text Integer
27+ | FracLiteral RealSrcSpan Text Rational
28+ deriving (GHC.Generic , Show , Ord , Eq , Data )
3029
3130instance NFData RealSrcSpan where
3231 rnf x = x `seq` ()
@@ -47,71 +46,40 @@ getSrcSpan = \case
4746
4847-- | Find all literals in a Parsed Source File
4948collectLiterals :: (Data ast , Typeable ast ) => ast -> [Literal ]
50- collectLiterals = S. toList . collectLiterals'
51-
52- collectLiterals' :: (Data ast , Typeable ast ) => ast -> Set Literal
53- collectLiterals' = everything (<>) (mkQ2 (S. empty :: Set Literal ) traverseLExpr traverseLPat)
54-
55- -- Located Patterns for whatever reason don't get picked up when using `(mkQ (S.empty :: Set Literal) traverseLExpr)
56- -- as such we need to explicit traverse those in order to pull out any literals
57- mkQ2 :: (Typeable a , Typeable b , Typeable c ) => r -> (b -> r ) -> (c -> r ) -> a -> r
58- mkQ2 def left right datum = case cast datum of
59- Just datum' -> left datum'
60- Nothing -> maybe def right (cast datum)
61-
62- traverseLPat :: GenLocated SrcSpan (Pat GhcPs ) -> Set Literal
63- traverseLPat (L sSpan pat) = traversePat sSpan pat
64-
65- traversePat :: SrcSpan -> Pat GhcPs -> Set Literal
66- traversePat sSpan = \ case
67- LitPat _ lit -> getLiteralAsList sSpan lit
68- NPat _ (L olSpan overLit) sexpr1 sexpr2 -> getOverLiteralAsList olSpan overLit
69- <> collectLiterals' sexpr1
70- <> collectLiterals' sexpr2
71- NPlusKPat _ _ (L olSpan loverLit) overLit sexpr1 sexpr2 -> getOverLiteralAsList olSpan loverLit
72- <> getOverLiteralAsList sSpan overLit
73- <> collectLiterals' sexpr1
74- <> collectLiterals' sexpr2
75- ast -> collectLiterals' ast
76-
77- traverseLExpr :: GenLocated SrcSpan (HsExpr GhcPs ) -> Set Literal
78- traverseLExpr (L sSpan hsExpr) = traverseExpr sSpan hsExpr
79-
80- traverseExpr :: SrcSpan -> HsExpr GhcPs -> Set Literal
81- traverseExpr sSpan = \ case
82- HsOverLit _ overLit -> getOverLiteralAsList sSpan overLit
83- HsLit _ lit -> getLiteralAsList sSpan lit
84- expr -> collectLiterals' expr
85-
86- getLiteralAsList :: SrcSpan -> HsLit GhcPs -> Set Literal
87- getLiteralAsList sSpan lit = case sSpan of
88- RealSrcSpan rss _ -> getLiteralAsList' lit rss
89- _ -> S. empty
90-
91- getLiteralAsList' :: HsLit GhcPs -> RealSrcSpan -> Set Literal
92- getLiteralAsList' lit = maybe S. empty S. singleton . flip getLiteral lit
93-
94- -- Translate from Hs Type to our Literal type
95- getLiteral :: RealSrcSpan -> HsLit GhcPs -> Maybe Literal
96- getLiteral sSpan = \ case
97- HsInt _ val -> fromIntegralLit sSpan val
98- HsRat _ val _ -> fromFractionalLit sSpan val
99- _ -> Nothing
100-
101- getOverLiteralAsList :: SrcSpan -> HsOverLit GhcPs -> Set Literal
102- getOverLiteralAsList sSpan lit = case sSpan of
103- RealSrcSpan rss _ -> getOverLiteralAsList' lit rss
104- _ -> S. empty
105-
106- getOverLiteralAsList' :: HsOverLit GhcPs -> RealSrcSpan -> Set Literal
107- getOverLiteralAsList' lit sSpan = maybe S. empty S. singleton (getOverLiteral sSpan lit)
108-
109- getOverLiteral :: RealSrcSpan -> HsOverLit GhcPs -> Maybe Literal
110- getOverLiteral sSpan OverLit {.. } = case ol_val of
111- HsIntegral il -> fromIntegralLit sSpan il
112- HsFractional fl -> fromFractionalLit sSpan fl
113- _ -> Nothing
114- getOverLiteral _ _ = Nothing
49+ collectLiterals = everything (<>) (maybeToList . (const Nothing `extQ` getLiteral `extQ` getPattern))
50+
51+ -- | Translate from HsLit and HsOverLit Types to our Literal Type
52+ getLiteral :: GenLocated SrcSpan (HsExpr GhcPs ) -> Maybe Literal
53+ getLiteral (L (UnhelpfulSpan _) _) = Nothing
54+ getLiteral (L (RealSrcSpan sSpan _ ) expr) = case expr of
55+ HsLit _ lit -> fromLit lit sSpan
56+ HsOverLit _ overLit -> fromOverLit overLit sSpan
57+ _ -> Nothing
58+
59+ -- | Destructure Patterns to unwrap any Literals
60+ getPattern :: GenLocated SrcSpan (Pat GhcPs ) -> Maybe Literal
61+ getPattern (L (UnhelpfulSpan _) _) = Nothing
62+ getPattern (L (RealSrcSpan patSpan _) pat) = case pat of
63+ LitPat _ lit -> case lit of
64+ HsInt _ val -> fromIntegralLit patSpan val
65+ HsRat _ val _ -> fromFractionalLit patSpan val
66+ _ -> Nothing
67+ NPat _ (L (RealSrcSpan sSpan _) overLit) _ _ -> fromOverLit overLit sSpan
68+ NPlusKPat _ _ (L (RealSrcSpan sSpan _) overLit1) _ _ _ -> fromOverLit overLit1 sSpan
69+ _ -> Nothing
70+
71+ fromLit :: HsLit p -> RealSrcSpan -> Maybe Literal
72+ fromLit lit sSpan = case lit of
73+ HsInt _ val -> fromIntegralLit sSpan val
74+ HsRat _ val _ -> fromFractionalLit sSpan val
75+ _ -> Nothing
76+
77+ fromOverLit :: HsOverLit p -> RealSrcSpan -> Maybe Literal
78+ fromOverLit OverLit {.. } sSpan = case ol_val of
79+ HsIntegral il -> fromIntegralLit sSpan il
80+ HsFractional fl -> fromFractionalLit sSpan fl
81+ _ -> Nothing
82+ fromOverLit _ _ = Nothing
11583
11684fromIntegralLit :: RealSrcSpan -> IntegralLit -> Maybe Literal
11785fromIntegralLit s (IL txt _ val) = fmap (\ txt' -> IntLiteral s txt' val) (fromSourceText txt)
0 commit comments