Skip to content
Browse files

load files with TH and QuasiQuotation

  • Loading branch information...
1 parent 4c23cb2 commit 9dda4b6b95facfda3d832df13794436a7bcb9bb2 Alan Zimmerman committed
View
18 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
View
13 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"
-- ---------------------------------------------------------------------
View
2 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
View
32 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
+
+
-- -----------------------------------
View
27 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|]
+
View
50 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
+ }
+

0 comments on commit 9dda4b6

Please sign in to comment.
Something went wrong with that request. Please try again.