load files with TH and QuasiQuotation

TODO.org

@@ -34,6 +34,24 @@
    see http://parenz.wordpress.com/2013/07/23/on-custom-error-handlers-for-ghc-api/
 ** TODO elisp: cancel option is not implemented
 ** TODO renaming getPid in hroq mnesia removes HM. qualification in client file
+** DONE handle TH splices, e.g. renaming Queue.hs getSid to getServerPid
+
+   Refactoring failed: "allocExpr undefined for 
+   (L {/home/alanz/mysrc/github/alanz/hroq/src/Data/Concurrent/Queue/Roq/DlqWorkers.hs:53:16-37} 
+    (HsSpliceE 
+     (HsSplice 
+      (Unqual {OccName: splice}) 
+      (L {/home/alanz/mysrc/github/alanz/hroq/src/Data/Concurrent/Queue/Roq/DlqWorkers.hs:53:18-36} 
+       (HsApp 
+        (L {/home/alanz/mysrc/github/alanz/hroq/src/Data/Concurrent/Queue/Roq/DlqWorkers.hs:53:18-26} 
+         (HsVar 
+          (Unqual {OccName: mkClosure}))) 
+        (L {/home/alanz/mysrc/github/alanz/hroq/src/Data/Concurrent/Queue/Roq/DlqWorkers.hs:53:28-36} 
+         (HsBracket 
+          (VarBr 
+           (True) 
+           (Unqual {OccName: requeuer})))))))))"
+
 ** TODO from the source files
    :PROPERTIES:
    :ID:       2930a92b-9989-427f-b02e-e47ca11a84de

src/Language/Haskell/Refact/Utils/Layout.hs

@@ -253,8 +253,6 @@ allocDecls decls toks = r
     (declLayout,tailToks) = foldl' doOne ([],toks) decls
 
     r = strip $ declLayout ++ (makeLeafFromToks tailToks)
-    -- r = error $ "allocDecls:tailToks=" ++ (show tailToks)
-    -- r = error $ "allocDecls:declLayout=" ++ (show declLayout)
 
     doOne :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])
     doOne acc d@(GHC.L _ (GHC.TyClD       _)) = allocTyClD       acc d
@@ -940,7 +938,8 @@ allocExpr e@(GHC.L _ (GHC.ExprWithTySigOut _ _)) _ = error $ "allocExpr undefine
 allocExpr e@(GHC.L _ (GHC.HsBracketOut _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0  e)
 
 
-allocExpr e@(GHC.L _ (GHC.HsSpliceE _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0  e)
+allocExpr (GHC.L _l (GHC.HsSpliceE (GHC.HsSplice _ expr))) toks = allocExpr expr toks
+
 allocExpr e@(GHC.L _ (GHC.HsQuasiQuoteE _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0  e)
 
 allocExpr (GHC.L l (GHC.HsProc p@(GHC.L lp _) cmd@(GHC.L lc _))) toks = r
@@ -1292,8 +1291,8 @@ allocSig (GHC.L l (GHC.SpecInstSig t)) toks = r
 
 -- ---------------------------------------------------------------------
 
-allocRecField :: GHC.HsRecFields GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> [PosToken] -> [LayoutTree]
-allocRecField = error "Layout.allocRecField undefined"
+-- allocRecField :: GHC.HsRecFields GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> [PosToken] -> [LayoutTree]
+-- allocRecField = error "Layout.allocRecField undefined"
 
 -- ---------------------------------------------------------------------
 
@@ -1541,8 +1540,8 @@ allocLFamInstDecl (GHC.L l (GHC.FamInstDecl n@(GHC.L ln _) (GHC.HsWB typs _ _) d
 allocLTyClDecl = error "allocLTyClDecl undefined"
 allocFunDep = error "allocFunDep undefined"
 
-allocHsTupArg :: GHC.HsTupArg GHC.RdrName -> [PosToken] -> [LayoutTree]
-allocHsTupArg = error "allocHsTupArg undefined"
+-- allocHsTupArg :: GHC.HsTupArg GHC.RdrName -> [PosToken] -> [LayoutTree]
+-- allocHsTupArg = error "allocHsTupArg undefined"
 
 -- ---------------------------------------------------------------------
 

src/Language/Haskell/Refact/Utils/TypeUtils.hs

@@ -1023,7 +1023,7 @@ hsFreeAndDeclaredGhc t = do
     pat (GHC.NPlusKPat (GHC.L _ n) _ _ _) = return (FN [],DN [n])
     pat _p@(GHC.SigPatIn (GHC.L _ p) b) = do
       fdp <- pat p
-      (FN fb,DN db) <- hsFreeAndDeclaredGhc b
+      (FN fb,DN _db) <- hsFreeAndDeclaredGhc b
       -- logm $ "hsFreeAndDeclaredGhc.pat.SigPatIn:p=" ++ showGhc _p
       -- logm $ "hsFreeAndDeclaredGhc.pat.SigPatIn:(fdp,(FN fb,DN db))=" ++ show (fdp,(FN fb,DN db))
 #if __GLASGOW_HASKELL__ > 704

test/DualTreeSpec.hs

@@ -5,8 +5,8 @@ import           Test.Hspec
 
 import qualified GHC        as GHC
 
--- import qualified GHC.SYB.Utils as SYB
--- import Data.Maybe
+import qualified GHC.SYB.Utils as SYB
+import Data.Maybe
 
 import Language.Haskell.Refact.Utils.DualTree
 import Language.Haskell.Refact.Utils.GhcBugWorkArounds
@@ -3476,5 +3476,33 @@ putToksAfterSpan test/testdata/AddParams1.hs:4:5:(((False,0,0,4),5),((False,0,0,
       (renderSourceTree srcTree) `shouldBe` origSource
 
 
+    -- ---------------------------------
+
+    it "retrieves the tokens in SourceTree format TemplateHaskell" $ do
+      (t,toks) <- parsedFileGhc "./test/testdata/TH/Main.hs"
+      let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t
+
+      -- let renamed = fromJust $ GHC.tm_renamed_source t
+      -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` ""
+
+      let origSource = (GHC.showRichTokenStream $ bypassGHCBug7351 toks)
+
+      let layout = allocTokens parsed toks
+      (show $ retrieveTokens layout) `shouldBe` (show toks)
+      (invariant layout) `shouldBe` []
+
+{-
+      (drawTreeCompact layout) `shouldBe`
+          ""
+-}
+
+      let srcTree = layoutTreeToSourceTree layout
+      -- (showGhc srcTree) `shouldBe` ""
+
+      -- (show $ retrieveLines srcTree) `shouldBe` ""
+
+      (renderSourceTree srcTree) `shouldBe` origSource
+
+
   -- -----------------------------------
 

test/testdata/TH/Main.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUGE QuasiQuotes #-}
+
+{- Main.hs -}
+module TH.Main where
+
+-- Import our template "pr"
+import TH.Printf
+
+-- The splice operator $ takes the Haskell source code
+-- generated at compile time by "pr" and splices it into
+-- the argument of "putStrLn".
+main = putStrLn ( $(pr "Hello") )
+
+-- import Control.Lens
+-- data Foo a = Foo { _fooArgs :: [String], _fooValue :: a }
+-- makeLenses ''Foo
+
+-- main = putStrLn "hello"
+
+-- longString = [str| hello |]
+
+
+baz = 'a'
+
+sillyString = [e|baz|]
+

test/testdata/TH/Printf.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{- Printf.hs -}
+module TH.Printf where
+
+-- Skeletal printf from the paper.
+-- It needs to be in a separate module to the one where
+-- you intend to use it.
+
+-- Import some Template Haskell syntax
+-- import Language.Haskell.THSyntax
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+import qualified Language.Haskell.TH as TH
+
+-- Describe a format string
+data Format = D | S | L String
+
+-- Parse a format string.  This is left largely to you
+-- as we are here interested in building our first ever
+-- Template Haskell program and not in building printf.
+parse :: String -> [Format]
+parse s   = [ L s ]
+
+-- Generate Haskell source code from a parsed representation
+-- of the format string.  This code will be spliced into
+-- the module which calls "pr", at compile time.
+gen :: [Format] -> ExpQ
+gen [D]   = [| \n -> show n |]
+gen [S]   = [| \s -> s |]
+gen [L s] = stringE s
+
+-- Here we generate the Haskell code for the splice
+-- from an input format string.
+pr :: String -> ExpQ
+pr s      = gen (parse s)
+
+-- str :: QuasiQuoter
+-- str = QuasiQuoter { quoteExp = stringE }
+
+silly :: QuasiQuoter
+silly = QuasiQuoter { quoteExp = \_ -> [| "yeah!!!" |] }
+
+silly2 :: QuasiQuoter
+silly2 = QuasiQuoter { quoteExp = \_ -> stringE "yeah!!!"
+                     , quotePat = undefined
+                     , quoteType = undefined
+                     , quoteDec = undefined
+                     }
+