/hareview/keep/HaskellGhcParser.hs

https://github.com/RefactoringTools/HaRe · Haskell · 294 lines · 102 code · 58 blank · 134 comment · 3 complexity · 07506c8397fa8c4eb0fb25fc7bb5eaa5 MD5 · raw file 

    

  1. {-# LANGUAGE ScopedTypeVariables #-}
    2. 

  2. module HaskellGhcParser where
    3. 

  3. 

  4. -- container
    5. 

  5. import Data.Tree (Tree(Node,rootLabel),drawTree)
    6. 

  6. 

  7. -- syb
    8. 

  8. import Data.Generics (Data)
    9. 

  9. 

  10. -- base
    11. 

  11. import Unsafe.Coerce (unsafeCoerce)
    12. 

  12. 

  13. 

  14. import Data.Generics
    15. 

  15. import qualified Data.Generics.Schemes as SYB
    16. 

  16. import qualified Data.Generics.Aliases as SYB
    17. 

  17. import qualified GHC.SYB.Utils         as SYB
    18. 

  18. 

  19. import qualified Bag                   as GHC
    20. 

  20. import qualified DynFlags              as GHC
    21. 

  21. import qualified ErrUtils              as GHC
    22. 

  22. import qualified FastString            as GHC
    23. 

  23. import qualified GHC
    24. 

  24. import qualified GHC.Paths             as GHC
    25. 

  25. import qualified MonadUtils            as GHC
    26. 

  26. import qualified NameSet               as GHC
    27. 

  27. import qualified OccName               as GHC
    28. 

  28. import qualified Outputable            as GHC
    29. 

  29. import qualified SrcLoc                as GHC
    30. 

  30. import qualified Var                   as GHC
    31. 

  31. 

  32. import GHC.Paths ( libdir )
    33. 

  33. import System.IO.Unsafe
    34. 

  34. 

  35. 

  36. -- local imports
    37. 

  37. import Language.Astview.Parser as Astview
    38. 

  38. import Language.Astview.DataTree
    39. 

  39. import Data.Tree (Tree(Node,rootLabel))
    40. 

  40. 

  41. import Language.Haskell.Exts (parseFileContents)
    42. 

  42. import Language.Haskell.Exts.Parser (ParseResult(ParseOk))
    43. 

  43. import Language.Haskell.Exts.Syntax (Module)
    44. 

  44. import Data.List
    45. 

  45. 

  46. haskellghc = Parser "Haskell" [".hs"] buildTreeHaskellGhc
    47. 

  47. 

  48. buildTreeHaskellGhc :: String -> Tree String
    49. 

  49. buildTreeHaskellGhc s = case parseHaskellGhc s of
    50. 

  50.      Right ast -> flat $ data2treeGhc (ast::GHC.Located (GHC.HsModule GHC.RdrName))
    51. 

  51.      -- Right ast -> flat $ data2tree (ast::GHC.Located (GHC.HsModule GHC.RdrName))
    52. 

  52.      Left ParseError -> Node "ParseError" []
    53. 

  53. 

  54. -- parseHaskellGhc :: (Data a) => String -> Either ParseError a
    55. 

  55. parseHaskellGhc :: String -> Either ParseError (GHC.Located (GHC.HsModule GHC.RdrName))
    56. 

  56. parseHaskellGhc s = case (foo s) of
    57. 

  57.     -- Right (_,p)  -> unsafeCoerce $ Right p
    58. 

  58.     Right (_,p)  -> Right p
    59. 

  59.     Left err -> Left ParseError
    60. 

  60. 

  61. 

  62. -- | Trealise Data to Tree (from SYB 2, sec. 3.4 )
    63. 

  63. --   bearing in mind the GHC parser stage holes
    64. 

  64. data2treeGhc :: Data a => a -> Tree String
    65. 

  65. data2treeGhc = data2treeGhcStaged SYB.Parser 0
    66. 

  66. -- data2treeGhc = data2tree
    67. 

  67. 

  68. 

  69. -- | Generic Data-based show, with special cases for GHC Ast types,
    70. 

  70. --   and simplistic indentation-based layout (the 'Int' parameter); 
    71. 

  71. --   showing abstract types abstractly and avoiding known potholes 
    72. 

  72. --   (based on the 'Stage' that generated the Ast)
    73. 

  73. -- data2treeGhcStaged stage n = const (Node "foo" [])
    74. 

  74. {-
    75. 

  75. data2treeGhcStaged :: Data a => SYB.Stage -> a -> Tree String
    76. 

  76. -- showData :: Data a => Stage -> Int -> a -> String
    77. 

  77. data2treeGhcStaged stage n = 
    78. 

  78.   {- generic 
    79. 

  79.           `ext1Q` list 
    80. 

  80.           `extQ` string 
    81. 

  81.           `extQ` fastString 
    82. 

  82.           `extQ` srcSpan 
    83. 

  83.           `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
    84. 

  84.           `extQ` bagName `extQ` bagRdrName `extQ` bagVar 
    85. 

  85.           -}
    86. 

  86.    {- (gdefault n)
    87. 

  87.           `ext1Q` -}
    88. 

  88.    'mkQ' (nameSet stage n)
    89. 

  89.           {-
    90. 

  90.           `extQ` postTcType `extQ` -}
    91. 

  91.    -- fixity n
    92. 

  92.           {-
    93. 

  93.           `extQ` gdefault
    94. 

  94.           -}
    95. 

  95.   where -- generic :: Data a => a -> Tree String
    96. 

  96.         -- generic t =  Node "(" ++ showConstr (toConstr t)
    97. 

  97.         --          ++ space (concat (intersperse " " (gmapQ (data2treeGhcStaged stage (n+1)) t))) ++ ")"
    98. 

  98.         -- space "" = ""
    99. 

  99.         -- space s  = ' ':s
    100. 

  100. 

  101. 

  102.         -- gdefault :: Data a => SYB.Stage -> a -> Tree String
    103. 

  103.         -- gdefault :: Data a => a -> Tree String
    104. 

  104.         gdefault x = Node (showConstr $ toConstr x) (gmapQ (data2treeGhcStaged stage) x) 
    105. 

  105. 

  106.        
    107. 

  107.         -- nameSet x 
    108. 

  108.         nameSet stage x 
    109. 

  109.                 | stage `elem` [SYB.Parser,SYB.TypeChecker] 
    110. 

  110.                 = const ( Node "{!NameSet placeholder here!}" []) -- :: GHC.NameSet -> Tree String
    111. 

  111.                 | otherwise     
    112. 

  112.                 -- = const (Node (showConstr $ toConstr x) (gmapQ (data2treeGhcStaged stage) x)) :: GHC.NameSet -> Tree String
    113. 

  113.                 = const ( Node "{!NameSet placeholder here!}" []) -- :: GHC.NameSet -> Tree String
    114. 

  114. 

  115.         postTcType | stage<SYB.TypeChecker = const (Node "{!type placeholder here?!}" []) :: GHC.PostTcType -> Tree String
    116. 

  116.                    -- | otherwise     = GHC.showSDoc . GHC.ppr :: GHC.Type -> Tree String
    117. 

  117.                    | otherwise     = const (Node "{!type placeholder here!}" []) :: GHC.Type -> Tree String
    118. 

  118. 

  119.         fixity | stage<SYB.Renamer = const (Node "{!fixity placeholder here?!}" []) :: GHC.Fixity -> Tree String
    120. 

  120.                | otherwise     = const (Node ("{Fixity: ") []) :: GHC.Fixity -> Tree String
    121. 

  121.                -- | otherwise     = const (Node (("{Fixity: "++) . (++"}") . GHC.showSDoc . GHC.ppr) []) :: GHC.Fixity -> Tree String
    122. 

  122. -}
    123. 

  123. 

  124. {-
    125. 

  125. -- | Generic Data-based show, with special cases for GHC Ast types,
    126. 

  126. --   and simplistic indentation-based layout (the 'Int' parameter); 
    127. 

  127. --   showing abstract types abstractly and avoiding known potholes 
    128. 

  128. --   (based on the 'Stage' that generated the Ast)
    129. 

  129. data2treeGhcStaged :: Data a => SYB.Stage -> a -> Tree String
    130. 

  130. -- showData :: Data a => Stage -> Int -> a -> String
    131. 

  131. data2treeGhcStaged stage n = 
    132. 

  132.   generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan 
    133. 

  133.           `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
    134. 

  134.           `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
    135. 

  135.           `extQ` postTcType `extQ` fixity
    136. 

  136.   where generic :: Data a => a -> String
    137. 

  137.         generic t = indent n ++ "(" ++ showConstr (toConstr t)
    138. 

  138.                  ++ space (concat (intersperse " " (gmapQ (data2treeGhcStaged stage (n+1)) t))) ++ ")"
    139. 

  139.         space "" = ""
    140. 

  140.         space s  = ' ':s
    141. 

  141.         indent n = "\n" ++ replicate n ' ' 
    142. 

  142.         string     = show :: String -> String
    143. 

  143.         fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String
    144. 

  144.         list l     = indent n ++ "[" 
    145. 

  145.                               ++ concat (intersperse "," (map (data2treeGhc stage (n+1)) l)) ++ "]"
    146. 

  146. 

  147.         name       = ("{Name: "++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.Name -> String
    148. 

  148.         occName    = ("{OccName: "++) . (++"}") .  GHC.occNameString 
    149. 

  149.         moduleName = ("{ModuleName: "++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.ModuleName -> String
    150. 

  150.         srcSpan    = ("{"++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.SrcSpan -> String
    151. 

  151.         var        = ("{Var: "++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.Var -> String
    152. 

  152.         dataCon    = ("{DataCon: "++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.DataCon -> String
    153. 

  153. 

  154.         bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String
    155. 

  155.         bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList 
    156. 

  156.         bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String
    157. 

  157.         bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList 
    158. 

  158.         bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String
    159. 

  159.         bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList 
    160. 

  160. 

  161.         nameSet | stage `elem` [SYB.Parser,SYB.TypeChecker] 
    162. 

  162.                 = const ("{!NameSet placeholder here!}") :: GHC.NameSet -> String
    163. 

  163.                 | otherwise     
    164. 

  164.                 = ("{NameSet: "++) . (++"}") . list . GHC.nameSetToList 
    165. 

  165. 

  166.         postTcType | stage<SYB.TypeChecker = const "{!type placeholder here?!}" :: GHC.PostTcType -> String
    167. 

  167.                    | otherwise     = GHC.showSDoc . GHC.ppr :: GHC.Type -> String
    168. 

  168. 

  169.         fixity | stage<SYB.Renamer = const "{!fixity placeholder here?!}" :: GHC.Fixity -> String
    170. 

  170.                | otherwise     = ("{Fixity: "++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.Fixity -> String
    171. 

  171. -}
    172. 

  172. 

  173. 

  174. -- ---------------------------------------------------------------------
    175. 

  175. 

  176. -- | Generic Data-based show, with special cases for GHC Ast types,
    177. 

  177. --   and simplistic indentation-based layout (the 'Int' parameter); 
    178. 

  178. --   showing abstract types abstractly and avoiding known potholes 
    179. 

  179. --   (based on the 'Stage' that generated the Ast)
    180. 

  180. data2treeGhcStaged :: Data a => SYB.Stage -> Int -> a -> Tree String
    181. 

  181. -- data2treeGhcStaged' :: Data a => SYB.Stage -> Int -> a -> String
    182. 

  182. data2treeGhcStaged stage n = 
    183. 

  183.   generic `ext1Q` list 
    184. 

  184.           `extQ` string 
    185. 

  185.           -- `extQ` fastString 
    186. 

  186.           -- `extQ` gname 
    187. 

  187.           -- `extQ` occName 
    188. 

  188.           -- `extQ` moduleName 
    189. 

  189.           -- `extQ` srcSpan 
    190. 

  190.           -- `extQ` var 
    191. 

  191.           -- `extQ` dataCon
    192. 

  192.           -- `extQ` bagName `extQ` bagRdrName `extQ` bagVar 
    193. 

  193.           `extQ` nameSet
    194. 

  194.           `extQ` postTcType 
    195. 

  195.           `extQ` fixity
    196. 

  196.   where generic :: Data a => a -> Tree String
    197. 

  197.         generic t = Node ("T:" ++ (showConstr (toConstr t))) (gmapQ (data2treeGhcStaged stage (n+1)) t)
    198. 

  198. 

  199.         space "" = ""
    200. 

  200.         space s  = ' ':s
    201. 

  201.         -- indent n' = "\n" ++ replicate n' ' ' 
    202. 

  202.         indent n' = ""
    203. 

    204. 

  204.         -- string     = show :: String -> String
    205. 

  205.         string     = const (Node ("show t") []) :: String -> Tree String
    206. 

  206.         
    207. 

  207. 

  208.         -- fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String
    209. 

  209. 

  210.         -- list l     = indent n ++ "[" 
    211. 

  211.         --                        ++ concat (intersperse "," (map (data2treeGhcStaged' stage (n+1)) l)) ++ "]"
    212. 

    213. 

  213.         -- list l     = Node (indent n ++ "[" 
    214. 

  214.         --                         ++ concat (intersperse "," ["a","b"]{- (map (data2treeGhcStaged' stage (n+1)) l) -}) ++ "]") []
    215. 

    216. 

  216.         list l     = Node "list" ((map (data2treeGhcStaged stage (n+1)) l))
    217. 

  217. 

  218. 

  219.         -- gname      = ("{Name: "++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.Name -> String
    220. 

  220.         -- occName    = ("{OccName: "++) . (++"}") .  GHC.occNameString 
    221. 

  221.         -- moduleName = ("{ModuleName: "++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.ModuleName -> String
    222. 

  222.         -- srcSpan    = ("{"++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.SrcSpan -> String
    223. 

  223.         -- var        = ("{Var: "++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.Var -> String
    224. 

  224.         -- dataCon    = ("{DataCon: "++) . (++"}") . GHC.showSDoc . GHC.ppr :: GHC.DataCon -> String
    225. 

  225. 

  226.         {-
    227. 

  227.         bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String
    228. 

  228.         bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList 
    229. 

  229.         bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String
    230. 

  230.         bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList 
    231. 

  231.         bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String
    232. 

  232.         bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList 
    233. 

  233.         -}
    234. 

  234. 

  235.         nameSet | stage `elem` [SYB.Parser,SYB.TypeChecker] 
    236. 

  236.                 = const (Node ("{!NameSet placeholder here!}") []) :: GHC.NameSet -> Tree String
    237. 

  237.         postTcType | stage<SYB.TypeChecker = const (Node "{!type placeholder here?!}" []) :: GHC.PostTcType -> Tree String
    238. 

  238.         fixity | stage<SYB.Renamer = const (Node "{!fixity placeholder here?!}" []) :: GHC.Fixity -> Tree String
    239. 

  239. 

  240. 

  241. -- ---------------------------------------------------------------------
    242. 

  242. 

  243. 

  244. 

  245. 

  246. parseHaskellGhc' ::
    247. 

  247.   String
    248. 

  248.   -> Either
    249. 

  249.        ParseError
    250. 

  250.        (GHC.WarningMessages, GHC.Located (GHC.HsModule GHC.RdrName))
    251. 

  251. parseHaskellGhc' s = case (foo s) of
    252. 

  252.     Right p  -> Right p
    253. 

  253.     Left err -> Left ParseError
    254. 

  254. 

  255. 

  256. foo s = do
    257. 

  257.   res <- unsafePerformIO $ parseSourceFile s
    258. 

  258.   return res
    259. 

  259. 

  260. 

  261. parseSourceFile ::
    262. 

  262.   String
    263. 

  263.   -> IO
    264. 

  264.        (Either
    265. 

  265.           GHC.ErrorMessages
    266. 

  266.           (GHC.WarningMessages, GHC.Located (GHC.HsModule GHC.RdrName)))
    267. 

  267. parseSourceFile s =
    268. 

  268.   GHC.defaultErrorHandler GHC.defaultLogAction $ do
    269. 

  269.     GHC.runGhc (Just GHC.libdir) $ do
    270. 

  270.       dflags <- GHC.getSessionDynFlags
    271. 

  271.       let dflags' = foldl GHC.xopt_set dflags
    272. 

  272.                     [GHC.Opt_Cpp, GHC.Opt_ImplicitPrelude, GHC.Opt_MagicHash]
    273. 

  273.       GHC.setSessionDynFlags dflags
    274. 

  274.       let result = GHC.parser s  dflags' "filename.hs"
    275. 

  275.           -- -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))	 
    276. 

  276.       return result
    277. 

  277. 

  278. 

  279. -- ---------------------------------------------------------------------
    280. 

  280. 

  281. -- | A simple test function to launch parsers from ghci.
    282. 

  282. --   When this works, astview should work too.
    283. 

  283. testParser :: Parser -> String -> IO ()
    284. 

  284. testParser p s = putStrLn $ drawTree $ (tree p) s
    285. 

  285. 

  286. tsrc = "main = putStrLn \"Hello World\""
    287. 

  287. 

  288. t = testParser haskellghc tsrc
    289. 

  289. 

  290. 

  291. p = putStrLn $ SYB.showData SYB.Parser 2 (parseHaskellGhc tsrc)
    292.