haskell-src-meta 0.1.1 → 0.8.16
raw patch · 25 files changed
Files
- ChangeLog +193/−0
- README.md +16/−0
- examples/BF.hs +214/−0
- examples/Hs.hs +50/−0
- examples/HsHere.hs +146/−0
- examples/SKI.hs +185/−0
- haskell-src-meta.cabal +74/−25
- src/Language/Haskell/Meta.hs +6/−5
- src/Language/Haskell/Meta/Extensions.hs +407/−0
- src/Language/Haskell/Meta/Parse.hs +71/−37
- src/Language/Haskell/Meta/QQ/BF.hs +0/−182
- src/Language/Haskell/Meta/QQ/Here.hs +0/−10
- src/Language/Haskell/Meta/QQ/Hs.hs +0/−34
- src/Language/Haskell/Meta/QQ/HsHere.hs +0/−106
- src/Language/Haskell/Meta/QQ/Idiom.hs +0/−44
- src/Language/Haskell/Meta/QQ/SKI.hs +0/−155
- src/Language/Haskell/Meta/Syntax.hs +0/−19
- src/Language/Haskell/Meta/Syntax/Translate.hs +828/−602
- src/Language/Haskell/Meta/Syntax/Vars.hs +0/−168
- src/Language/Haskell/Meta/THCompat.hs +30/−0
- src/Language/Haskell/Meta/Utils.hs +138/−244
- src/Language/Haskell/TH/Instances/Lift.hs +0/−57
- tests/Main.hs +89/−0
- tests/Splices.hs +78/−0
- tests/TestExamples.hs +53/−0
+ ChangeLog view
@@ -0,0 +1,193 @@+0.8.15+- Support for GHC 9.12 (by alexfmpe)++0.8.14+- Support for GHC 9.10 (by Troels Henriksen)++0.8.13+- Support for GHC 9.8 (by Vladislav Zavialov)++0.8.12+- Support for GHC 9.6 (by Troels Henriksen)++0.8.11+- Support for GHC 9.4 (by Matt Parsons)++0.8.10+- Support for GHC 9.4 alpha (by Matt Parsons)++0.8.9+- Add `toExtension` and `fromExtension` to convert between HSE and TH language extensions (by Konstantin Ivanov)++0.8.8+- Implement toDec for AnnPragma (by Matt Torrence)+- Add support for OverloadedLabels (by funketh)+- Fix order of promoted type tuples in resulting TH (by Alexander V. Nikolaev)++0.8.7.1+- Build on GHC 9.2+- Drop support for GHC < 8.2++0.8.7:+- Compatibility with template-haskell shipped with GHC 9.0++0.8.6:+- Add TypeApplications to default extensions++0.8.5:+- Compatibility with template-haskell shipped with GHC 8.10++0.8.4:+- Bump base and template-haskell library to versions shipped with GHC 7.10+- Compatibility with haskell-src-exts 1.22++0.8.3:+- Compatibility with GHC 8.8, by fixing MonadFail issues++0.8.2:+- Added ToExp implementation for type application+- Added parseDecsWithMode and parseHsDeclsWithMode++0.8.1:+- Compatibility with GHC 8.6, haskell-src-exts 1.21++0.8.0.1:+- Bump base and template-haskell library to versions shipped with GHC 7.6.++0.8:+- Compatibility with GHC 8.2.+- Remove deprecated modules.++0.7.0.1:+- Fixed a bug that caused deriving clauses to be ignored on TH 2.11.++0.7.0:+- Compatibility with haskell-src-exts 1.18.+- Support dropped for GHC < 7.6 and haskell-src-exts < 1.17.++0.6.0.14:+- Compatibility with GHC 8.0.++0.6.0.13:+- Compatibility with GHC HEAD, haskell-src-exts 1.17+- Remove hsBindsToDecs, since it was redundant with toDecs. Technically this+ requires a minor-version bump, but I doubt anyone was using it.++0.6.0.12:+- Support th-orphans 0.13++0.6.0.11:+- Support syb 0.6++0.6.0.10:+- Support syb 0.5, th-orphans 0.12++0.6.0.9:+- Compatibility with GHC 7.10+- Update th-orphans dependency+- Drop GHC < 7.4 support (actually it was already broken, since HSE 1.16+ requires base >= 4.5)++0.6.0.8:+- Move to HSE 1.16++0.6.0.7:+- Fix compilation oops++0.6.0.6:+- Move to HSE 1.15, adding support for multiway if++0.6.0.5:+- Update th-orphans dependency++0.6.0.4:+- Drop support for GHC 6.12+- Move to HSE 1.14++0.6.0.3:+- Update th-orphans dependency+- Some dependency loosening in anticipation of GHC 7.8++0.6.0.2:+- Update syb dependency++0.6.0.1:+- Fix haddock parse error++0.6:+- Cabal category Template Haskell+- Partial support for list comprehensions+- Support for type and data families and class decs+- Split orphan instances into new package th-orphans+ - above changes courtesy of mgsloan+ - L.H.TH.Instances.Lift now deprecated+- Removed L.H.M.Utils.deriveLiftPretty, dropped th-lift dependency+- Rename L.H.M.Utils.unQ to unsafeRunQ+- instance ToName Op+- Support for unboxed tuple types and kind signatures+- Compatibility with GHC 7.6.1, bringing support for kind variables+ and infix declarations++0.5.1.2:+- More sensible determination of TH version available++0.5.1.1:+- View pattern support, thanks to Nicolas Frisby.++0.5.1:+- New module Language.Haskell.Meta.Parse.Careful, written by Reiner Pope+ so that ambiguous parses can be rejected instead of quietly done wrong.++0.5.0.3:+- Support for GHC 7.4, thanks to Reiner Pope+- Support for unresolved infix expressions, again thanks to Reiner Pope++0.5.0.2:+- Fixed bug in translation of tuple constructors++0.5.0.1:+- Added support for primitive string literals (Only in TH >= 2.5)++0.5:+- Added support for instance declarations++0.4.0.2:+- Compatibility with GHC 7.2++0.4.0.1:+- Deprecate myDefaultParseMode and myDefaultExtensions in L.H.M.Parse++0.4:+- Remove Language.Haskell.Meta.Syntax.Vars and the L.H.M.Syntax re-export module+- Remove dependency on containers+- Add support for let statements in (pattern) guards+- Add support for negative patterns+- Remove "support" for SpliceExps that didn't really make sense+- Improve many error messages where things are unimplemented or impossible++0.3:+- Fixes/additions to inline pragma support (Jonas Duregard)+- Compatibility with GHC 7 and TH 2.5 - totalling three major versions!+- Move some of the quasiquoters to their own package, and stop exporting+ the rest (they are kept as examples of usage)++0.2:+- Compatibility with GHC 6.10 and TH 2.3 (Geoffrey Mainland)+- Add support for do-blocks, pattern guards (Adam Vogt)+- Add applicative-do quasiquoter (Adam Vogt)++0.1.1:+- Add support for inline pragmas, and improve support for type+ signatures (patch by Jonas Duregard)++0.1.0:+- Used the th-lift library to autogenerate the instances of Lift in+ Language.Haskell.TH.Instances.Lift+- Added support for the new features of template-haskell-2.4.0.0:+ contexts, kinds, bang patterns, unboxed word literals.+- Updated use of haskell-src-exts in response to API changes.+- Added ToDecs class because some HSE Decls don't map to a single Dec.+ (patch by Jonas Duregard)++0.0.6:+- last version released by Matt Morrow before his disappearance
+ README.md view
@@ -0,0 +1,16 @@+The `haskell-src-meta` Package [](https://hackage.haskell.org/package/haskell-src-meta) [](https://travis-ci.org/DanBurton/haskell-src-meta)+==================++`haskell-src-meta` is a package originally by Matt Morrow for converting a+parsed AST from `haskell-src-exts` to a TH AST for use in splices and+quasiquoters. The last version Matt released before he disappeared from the+Haskell community was 0.0.6, but by that time his library was already popular,+so some community members eventually decided to take over maintenance of the+package, keeping it up to date with the latest versions of TH etc.++I don't really view this as "my" package so if you want write access to+the github repository, or you think you could do a better job as+maintainer, just ask.++The above was written by Ben Millwood,+but I (Dan Burton) share the same sentiment.
+ examples/BF.hs view
@@ -0,0 +1,214 @@+-- TODO: knock out these warnings+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module BF (+ bf,bf2,bfHelloWorld,eval_,parse, exec, test0+) where++import Language.Haskell.Meta (parsePat)+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++import qualified Control.Monad.Fail as Fail+import Data.Char+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM++-- TODO: narrow type & move to shared module+quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a+quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++)++-- TODO: narrow type & move to shared module+quoteDecNotImplemented :: Fail.MonadFail m => String -> m a+quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ )++bf :: QuasiQuoter+bf = QuasiQuoter+ { quoteExp = bfExpQ+ , quotePat = bfPatQ+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented+ }++bf2 :: QuasiQuoter+bf2 = QuasiQuoter+ { quoteExp = bf2ExpQ+ , quotePat = bfPatQ+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented+ }++bf2ExpQ :: String -> ExpQ+bf2ExpQ s = [|eval (parse s)|]++bfExpQ :: String -> ExpQ+bfExpQ s = [|eval_ (parse s)|]++bfPatQ :: String -> PatQ+bfPatQ s = do+ let p = (parsePat+ . show+ . parse) s+ case p of+ Left e -> fail e+ Right p -> return p++instance Lift Bf where+ lift Inp = [|Inp|]+ lift Out = [|Out|]+ lift Inc = [|Inc|]+ lift Dec = [|Dec|]+ lift MovL = [|MovL|]+ lift MovR = [|MovR|]+ lift (While xs) = [|While $(lift xs)|]++#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = unsafeCodeCoerce . lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift+ -- TODO: get stylish haskell to be happy w/ the below+ -- liftTyped Inp = [||Inp||]+ -- liftTyped Out = [||Out||]+ -- liftTyped Inc = [||Inc||]+ -- liftTyped Dec = [||Dec||]+ -- liftTyped MovL = [||MovL||]+ -- liftTyped MovR = [||MovR||]+ -- liftTyped (While xs) = [||While $$(liftTyped xs)||]+#endif+++type Ptr = Int+newtype Mem = Mem (IntMap Int) deriving (Show)++data Bf = Inp+ | Out+ | Inc+ | Dec+ | MovL+ | MovR+ | While [Bf]+ deriving (Eq,Ord,Read,Show)++data Status = D Ptr Mem+ | W Int Status+ | R (Int -> Status)++-- ghci> exec (parse helloWorld)+-- Hello World!+-- (4,Mem (fromList [(0,0),(1,87),(2,100),(3,33),(4,10)]))+bfHelloWorld :: String+bfHelloWorld = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."++eval_ :: [Bf] -> (String -> String)+eval_ is = go (run 0 initMem is)+ where go (D p m) _ = []+ go (W n s) cs = chr n : go s cs+ go (R cont) [] = "*** Exception: bf blocked on input"+ go (R cont) (c:cs) = go ((cont . ord) c) cs++eval :: [Bf] -> String -> (String, (Ptr, Mem))+eval is = go [] (run 0 initMem is)+ where go acc (D p m) _ = (reverse acc, (p, m))+ go acc (W n s) cs = go (chr n:acc) s cs+ go _ (R cont) [] = ("*** Exception: bf blocked on input",(-1, Mem IM.empty))+ go acc (R cont) (c:cs) = go acc ((cont . ord) c) cs++exec :: [Bf] -> IO (Ptr, Mem)+exec is = go (run 0 initMem is)+ where go (D p m) = return (p, m)+ go (W n s) = putChar (chr n) >> go s+ go (R cont) = go . cont . ord =<< getChar++run :: Ptr -> Mem -> [Bf] -> Status+run dp m is = step dp m is (\dp m -> D dp m)++step :: Ptr -> Mem -> [Bf] -> (Ptr -> Mem -> Status) -> Status+step dp m [] k = k dp m+step dp m (Inc:is) k = step dp (inc dp m) is k+step dp m (Dec:is) k = step dp (dec dp m) is k+step dp m (MovL:is) k = step (dp-1) m is k+step dp m (MovR:is) k = step (dp+1) m is k+step dp m (Inp:is) k = R (\c -> step dp (wr m dp c) is k)+step dp m (Out:is) k = W (rd m dp) (step dp m is k)+step dp m (While xs:is) k = let go dp m = if rd m dp == 0+ then step dp m is k+ else step dp m xs go+ in go dp m++initMem :: Mem+initMem = Mem IM.empty++inc :: Ptr -> (Mem -> Mem)+dec :: Ptr -> (Mem -> Mem)+rd :: Mem -> Ptr -> Int+wr :: Mem -> Ptr -> Int -> Mem+upd :: Mem -> Ptr -> (Int -> Int) -> Mem+inc p m = upd m p (+1)+dec p m = upd m p (subtract 1)+rd (Mem m) p = maybe 0 id (IM.lookup p m)+wr (Mem m) p n = Mem (IM.insert p n m)+upd m p f = wr m p (f (rd m p))++parse :: String -> [Bf]+parse s = go 0 [] s (\_ xs _ -> xs)+ where go :: Int -> [Bf] -> String+ -> (Int -> [Bf] -> String -> o) -> o+ go !n acc [] k = k n (reverse acc) []+ go !n acc (',':cs) k = go (n+1) (Inp:acc) cs k+ go !n acc ('.':cs) k = go (n+1) (Out:acc) cs k+ go !n acc ('+':cs) k = go (n+1) (Inc:acc) cs k+ go !n acc ('-':cs) k = go (n+1) (Dec:acc) cs k+ go !n acc ('<':cs) k = go (n+1) (MovL:acc) cs k+ go !n acc ('>':cs) k = go (n+1) (MovR:acc) cs k+ go !n acc ('[':cs) k = go (n+1) [] cs (\n xs cs ->+ go n (While xs:acc) cs k)+ go !n acc (']':cs) k = k (n+1) (reverse acc) cs+ go !n acc (c :cs) k = go n acc cs k+++test0 :: IO [Bf]+test0 = do+ a <- readFile "prime.bf"+ return (parse a)++++++++{-+data Bf = Inp+ | Out+ | Inc+ | Dec+ | MovL+ | MovR+ | While [Bf]+ | Error String+ deriving (Eq,Ord,Read,Show)++parse :: String -> [Bf]+parse s = let p n s = case go n [] s of+ (_,xs,[]) -> xs+ (n,xs, s) -> xs ++ p n s+ in p 0 s+ where go :: Int -> [Bf] -> [Char] -> (Int, [Bf], String)+ go !n acc [] = (n, reverse acc, [])+ go !n acc (',':cs) = go (n+1) (Inp:acc) cs+ go !n acc ('.':cs) = go (n+1) (Out:acc) cs+ go !n acc ('+':cs) = go (n+1) (Inc:acc) cs+ go !n acc ('-':cs) = go (n+1) (Dec:acc) cs+ go !n acc ('<':cs) = go (n+1) (MovL:acc) cs+ go !n acc ('>':cs) = go (n+1) (MovR:acc) cs+ go !n acc ('[':cs) = case go (n+1) [] cs of+ (n,xs,cs) -> go n (While xs:acc) cs+ go !n acc (']':cs) = (n+1, reverse acc, cs)+ go !n acc (c :cs) = (n+1, [Error ("go error: char "++show n+ ++" illegal character: "++show c)], [])+-}
+ examples/Hs.hs view
@@ -0,0 +1,50 @@+++-- | Eat your face!++module Hs (hs, pat) where++import Language.Haskell.Meta (parseExp, parsePat)+import Language.Haskell.Meta.Utils (pretty)+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++import qualified Control.Monad.Fail as Fail++-- TODO: narrow type & move to shared module+quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a+quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++)++-- TODO: narrow type & move to shared module+quoteDecNotImplemented :: Fail.MonadFail m => String -> m a+quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ )++-- |+-- > ghci> [$hs|\x -> (x,x)|] 42+-- > (42,42)+-- > ghci> (\[$hs|a@(x,_)|] -> (a,x)) (42,88)+-- > ((42,88),42)+hs :: QuasiQuoter+hs = QuasiQuoter+ { quoteExp = either fail transformE . parseExp+ , quotePat = either fail transformP . parsePat+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented+ }++transformE :: Exp -> ExpQ+transformE = return++transformP :: Pat -> PatQ+transformP = return++pat :: QuasiQuoter+pat = QuasiQuoter+ { quoteExp = quoteExp hs+ , quotePat = \s -> case parseExp s of+ Left err -> fail err+ Right e -> either fail return (parsePat . pretty $ e)+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented+ }
+ examples/HsHere.hs view
@@ -0,0 +1,146 @@+-- TODO: knock out these warnings+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}++module HsHere+ ( here+ , lexemeP+ , nestedP+ , parensP+ , bracksP+ , oparenP+ , obrackP+ , cbrackP+ ) where++import qualified Control.Monad.Fail as Fail+import Data.Generics (Data)+import Language.Haskell.Meta (parseExp, parsePat)+import Language.Haskell.Meta.Utils (cleanNames)+import Language.Haskell.TH.Lib hiding (parensP)+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Text.ParserCombinators.ReadP++-- TODO: narrow type & move to shared module+quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a+quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++)++-- TODO: narrow type & move to shared module+quoteDecNotImplemented :: Fail.MonadFail m => String -> m a+quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ )+++data Here+ = CodeH Exp+ | TextH String+ | ManyH [Here]+ deriving (Eq,Show,Data)++-- | Example:+--+-- > a x = [here| random "text" $(x + 1)+-- > something else|]+--+-- Is like:+--+-- > a x = " random \"text\" "++ show (x + 1) ++"\n something else"+here :: QuasiQuoter+here = QuasiQuoter+ {quoteType = quoteTypeNotImplemented+ ,quoteDec = quoteDecNotImplemented+ ,quoteExp = hereExpQ+ ,quotePat = herePatQ}++instance Lift Here where+ lift (TextH s) = (litE . stringL) s+ lift (CodeH e) = [|show $(return e)|]+ lift (ManyH hs) = [|concat $(listE (fmap lift hs))|]++#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = unsafeCodeCoerce . lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift -- TODO: the right way?+#endif+++hereExpQ :: String -> ExpQ+hereExpQ s = case run s of+ [] -> fail "here: parse error"+ e:_ -> lift (cleanNames e)++herePatQ :: String -> PatQ+herePatQ s = do+ e <- hereExpQ s+ let p = (parsePat+ . pprint+ . cleanNames) e+ case p of+ Left e -> fail e+ Right p -> return p++run :: String -> [Here]+run = fst . parse++parse :: String -> ([Here], String)+parse = runP hereP++hereP :: ReadP Here+hereP = (ManyH . mergeTexts)+ `fmap` many (oneP =<< look)++mergeTexts :: [Here] -> [Here]+mergeTexts [] = []+mergeTexts (TextH s:TextH t:hs)+ = mergeTexts (TextH (s++t):hs)+mergeTexts (h:hs) = h : mergeTexts hs++oneP :: String -> ReadP Here+oneP s+ | [] <- s = pfail+ | '\\':'$':s <- s = do skip 2+ (TextH . ("\\$"++))+ `fmap` munch (/='\\')+ | '$':'(':s <- s = skip 2 >> go 1 [] s+ | c:s <- s = do skip 1+ (TextH . (c:))+ `fmap` munch (not.(`elem`"\\$"))+ where go :: Int -> String -> String -> ReadP Here+ go _ acc [] = return (TextH (reverse acc))+ go 1 [] (')':_) = skip 1 >> return (TextH "$()")+ go 1 acc (')':_) = do skip (1 + length acc)+ let s = reverse acc+ either (const (return+ (TextH s)))+ (return . CodeH)+ (parseExp s)+ go n acc ('(':s) = go (n+1) ('(':acc) s+ go n acc (')':s) = go (n-1) (')':acc) s+ go n acc (c:s) = go n (c:acc) s+++runP :: ReadP a -> String -> ([a], String)+runP p s = case readP_to_S p s of+ [] -> ([],[])+ xs -> mapfst (:[]) (last xs)+ where mapfst f (a,b) = (f a,b)+skip :: Int -> ReadP ()+skip n = count n get >> return ()+lexemeP :: ReadP a -> ReadP a+lexemeP p = p >>= \x -> skipSpaces >> return x+nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)+nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)+parensP, bracksP :: ReadP a -> ReadP a+parensP = between oparenP cparenP+bracksP = between oparenP cparenP+oparenP, cparenP, obrackP, cbrackP :: ReadP Char+oparenP = char '('+cparenP = char ')'+obrackP = char '['+cbrackP = char ']'
+ examples/SKI.hs view
@@ -0,0 +1,185 @@+-- TODO: knock out these warnings+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}++module SKI+ ( SKI(..)+ , ski+ , parse+ , bracksP+ , obrackP+ , cbrackP+ ) where++import qualified Control.Monad.Fail as Fail+import Data.Generics (Data)+import Language.Haskell.Meta (parseExp, parsePat)+import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unsafeRunQ)+import Language.Haskell.TH.Lib hiding (parensP)+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Text.ParserCombinators.ReadP+import Text.PrettyPrint (render)++-- TODO: narrow type & move to shared module+quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a+quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++)++-- TODO: narrow type & move to shared module+quoteDecNotImplemented :: Fail.MonadFail m => String -> m a+quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ )+++data SKI = S | K | I | E Exp | SKI :$ SKI+ deriving (Eq,Data)++run :: String -> [SKI]+run = fmap eval . fst . parse++-- I x = x+-- K x y = x+-- S x y z = (x z) (y z)+eval :: SKI -> SKI+eval (I :$ x) = eval x+eval ((K :$ x) :$ y) = eval x+eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))+eval (E e :$ E e') = E (unsafeRunQ[|$(return e) $(return e')|])+eval (x :$ y) = eval0 ((eval x) :$ (eval y))+eval x = x+eval0 (I :$ x) = eval x+eval0 ((K :$ x) :$ y) = eval x+eval0 (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))+eval0 (E e :$ E e') = E (unsafeRunQ[|$(return e) $(return e')|])+eval0 x = x++ski :: QuasiQuoter+ski = QuasiQuoter+ { quoteExp = skiExpQ+ , quotePat = skiPatQ+ , quoteType = quoteTypeNotImplemented+ , quoteDec = quoteDecNotImplemented+ }++instance Lift SKI where+ lift = liftSKI+#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = unsafeCodeCoerce . lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift -- TODO: the right way?+#endif++liftSKI (E e) = return e+liftSKI a = go a+ where go S = [|S|]+ go K = [|K|]+ go I = [|I|]+ go (E e) = [|E e|]+ go (x:$y) = [|$(go x) :$ $(go y)|]++instance Show SKI where+ showsPrec p (S) = showString "S"+ showsPrec p (K) = showString "K"+ showsPrec p (I) = showString "I"+ showsPrec p (E x1)+ = showParen (p > 10)+ (showString (render (ppDoc x1)))+ showsPrec p ((:$) x1 x2)+ = showParen (p > 10)+ (showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2))++skiExpQ :: String -> ExpQ+skiExpQ s = case run s of+ [] -> fail "ski: parse error"+ e:_ -> lift (cleanNames e)++skiPatQ :: String -> PatQ+skiPatQ s = do+ e <- skiExpQ s+ let p = (parsePat+ . pprint+ . cleanNames) e+ case p of+ Left e -> fail e+ Right p -> return p++-- ghci> parse "S(SS)IK(SK)"+-- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"")+parse :: String -> ([SKI], String)+parse = runP skiP++skiP :: ReadP SKI+skiP = nestedP parensP+ (let go a = (do b <- lexemeP (oneP <++ skiP)+ go (a:$b)) <++ return a+ in lexemeP (go =<< lexemeP oneP))++oneP :: ReadP SKI+oneP = nestedP parensP+ (lexemeP (choice [sP+ ,kP+ ,iP+ ,spliceP =<< look+ ]))++spliceP :: String -> ReadP SKI+spliceP s+ | '[':s <- s = skip 1 >> go 1 [] s+ | otherwise = pfail+ where go _ _ [] = pfail+ go 1 acc (']':_) = do skip (1 + length acc)+ either (const pfail)+ (return . E)+ (parseExp (reverse acc))+ go n acc ('[':s) = go (n+1) ('[':acc) s+ go n acc (']':s) = go (n-1) (']':acc) s+ go n acc (c:s) = go n (c:acc) s++++sP = (char 's' +++ char 'S') >> return S+kP = (char 'k' +++ char 'K') >> return K+iP = (char 'i' +++ char 'I') >> return I++runP :: ReadP a -> String -> ([a], String)+runP p s = case readP_to_S p s of+ [] -> ([],[])+ xs -> mapfst (:[]) (last xs)+ where mapfst f (a,b) = (f a,b)+skip :: Int -> ReadP ()+skip n = count n get >> return ()+lexemeP :: ReadP a -> ReadP a+lexemeP p = p >>= \x -> skipSpaces >> return x+nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)+nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)+parensP = between oparenP cparenP+bracksP = between oparenP cparenP+oparenP = char '('+cparenP = char ')'+obrackP = char '['+cbrackP = char ']'+++++{-+import Prelude hiding (($))+data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show+S Nothing $ x = S (Just (x, Nothing))+S (Just (x, Nothing)) $ y = S (Just (x, Just y))+S (Just (x, Just y)) $ z = x $ z $ (y $ z)+K Nothing $ x = K (Just x)+K (Just x) $ y = y+q x = x $ (c $ k) $ k $ k $ s+ where s = S Nothing+ k = K Nothing+ c = s $ (b $ b $ s) $ k $ k+ b = s $ (k $ s) $ k+-}
haskell-src-meta.cabal view
@@ -1,39 +1,88 @@ name: haskell-src-meta-version: 0.1.1-cabal-version: >= 1.6+version: 0.8.16+cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE-category: Language+category: Language, Template Haskell author: Matt Morrow copyright: (c) Matt Morrow-maintainer: Ben Millwood <haskell@benmachine.co.uk>-stability: experimental+maintainer: athas@sigkill.dk+bug-reports: https://github.com/haskell-party/haskell-src-meta/issues+tested-with: GHC == 9.14.1 synopsis: Parse source to template-haskell abstract syntax. description: The translation from haskell-src-exts abstract syntax to template-haskell abstract syntax isn't 100% complete yet. +extra-source-files: ChangeLog README.md+ library- build-depends: base == 4.2.*, containers == 0.3.*,- haskell-src-exts >= 1.6 && < 1.10,- template-haskell == 2.4.*,- pretty == 1.0.*, syb >= 0.1 && < 0.2, th-lift == 0.5.*- hs-source-dirs: src- exposed-modules: Language.Haskell.Meta,- Language.Haskell.Meta.Parse,- Language.Haskell.Meta.Syntax,- Language.Haskell.Meta.Syntax.Vars,- Language.Haskell.Meta.Syntax.Translate,- Language.Haskell.TH.Instances.Lift,- Language.Haskell.Meta.Utils,- Language.Haskell.Meta.QQ.Hs,- Language.Haskell.Meta.QQ.Here,- Language.Haskell.Meta.QQ.HsHere,- Language.Haskell.Meta.QQ.Idiom,- Language.Haskell.Meta.QQ.BF,- Language.Haskell.Meta.QQ.SKI+ default-language: Haskell2010+ build-depends: base >= 4.10 && < 5,+ haskell-src-exts >= 1.21 && < 1.25,+ pretty >= 1.0 && < 1.2,+ syb >= 0.1 && < 0.8,+ template-haskell >= 2.12 && < 2.25,+ th-orphans >= 0.12 && < 0.14 + hs-source-dirs: src+ exposed-modules: Language.Haskell.Meta+ Language.Haskell.Meta.Extensions+ Language.Haskell.Meta.Parse+ Language.Haskell.Meta.Syntax.Translate+ Language.Haskell.Meta.Utils+ other-modules: Language.Haskell.Meta.THCompat++test-suite unit+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Main.hs++ build-depends:+ HUnit >= 1.2,+ base >= 4.10,+ haskell-src-exts >= 1.21,+ haskell-src-meta,+ pretty >= 1.0,+ template-haskell >= 2.12,+ tasty,+ tasty-hunit+++test-suite splices+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Splices.hs++ build-depends:+ base,+ haskell-src-exts,+ haskell-src-meta,+ template-haskell++test-suite examples+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: examples, tests+ main-is: TestExamples.hs++ build-depends:+ base,+ containers,+ haskell-src-meta,+ pretty,+ syb,+ template-haskell+++ other-modules:+ BF,+ Hs,+ HsHere,+ SKI+ source-repository head type: git- location: git://github.com/benmachine/haskell-src-meta.git-+ location: https://github.com/haskell-party/haskell-src-meta.git
src/Language/Haskell/Meta.hs view
@@ -1,4 +1,3 @@- {- | Module : Language.Haskell.Meta Copyright : (c) Matt Morrow 2008@@ -9,10 +8,12 @@ -} module Language.Haskell.Meta (- module Language.Haskell.Meta.Parse- , module Language.Haskell.Meta.Syntax+ module Language.Haskell.Meta.Extensions,+ module Language.Haskell.Meta.Parse,+ module Language.Haskell.Meta.Syntax.Translate ) where +import Language.Haskell.Meta.Extensions import Language.Haskell.Meta.Parse-import Language.Haskell.Meta.Syntax-import Language.Haskell.TH.Instances.Lift()+import Language.Haskell.Meta.Syntax.Translate+import Language.Haskell.TH.Instances ()
+ src/Language/Haskell/Meta/Extensions.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE CPP #-}+{- |+ Module : Language.Haskell.Meta.Parse+ Copyright : (c) Serokell 2022, Adam Bergmark 2022+ License : BSD3+ Maintainer : Adam Bergmark <adam@bergmark.nl>+ Stability : experimental+ Portability : portable (template-haskell)+-}++module Language.Haskell.Meta.Extensions (+ toExtension,+ fromExtension+ ) where++import qualified Language.Haskell.Exts.Extension as Exts+import qualified Language.Haskell.TH.Syntax as TH+++-----------------------------------------------------------------------------++-- * To template-haskell++-- | Returns @Nothing@ when the extension is not supported by template-haskell.+toExtension :: Exts.KnownExtension -> Maybe TH.Extension+toExtension e = case e of+ Exts.OverlappingInstances -> Just TH.OverlappingInstances+ Exts.UndecidableInstances -> Just TH.UndecidableInstances+ Exts.IncoherentInstances -> Just TH.IncoherentInstances+ Exts.InstanceSigs -> Just TH.InstanceSigs+ Exts.DoRec -> Nothing+ Exts.RecursiveDo -> Just TH.RecursiveDo+ Exts.ParallelListComp -> Just TH.ParallelListComp+ Exts.MultiParamTypeClasses -> Just TH.MultiParamTypeClasses+ Exts.MonomorphismRestriction -> Just TH.MonomorphismRestriction+ Exts.FunctionalDependencies -> Just TH.FunctionalDependencies+ Exts.Rank2Types -> Nothing+ Exts.RankNTypes -> Just TH.RankNTypes+ Exts.PolymorphicComponents -> Nothing+ Exts.ExistentialQuantification -> Just TH.ExistentialQuantification+ Exts.ScopedTypeVariables -> Just TH.ScopedTypeVariables+ Exts.PatternSignatures -> Nothing+ Exts.ImplicitParams -> Just TH.ImplicitParams+ Exts.FlexibleContexts -> Just TH.FlexibleContexts+ Exts.FlexibleInstances -> Just TH.FlexibleInstances+ Exts.EmptyDataDecls -> Just TH.EmptyDataDecls+ Exts.CPP -> Just TH.Cpp+ Exts.KindSignatures -> Just TH.KindSignatures+ Exts.BangPatterns -> Just TH.BangPatterns+ Exts.TypeSynonymInstances -> Just TH.TypeSynonymInstances+ Exts.TemplateHaskell -> Just TH.TemplateHaskell+ Exts.ForeignFunctionInterface -> Just TH.ForeignFunctionInterface+ Exts.Arrows -> Just TH.Arrows+ Exts.Generics -> Nothing+ Exts.ImplicitPrelude -> Just TH.ImplicitPrelude+ Exts.NamedFieldPuns -> Nothing+ Exts.PatternGuards -> Just TH.PatternGuards+ Exts.GeneralizedNewtypeDeriving -> Just TH.GeneralizedNewtypeDeriving+ Exts.DeriveAnyClass -> Just TH.DeriveAnyClass+ Exts.ExtensibleRecords -> Nothing+ Exts.RestrictedTypeSynonyms -> Nothing+ Exts.HereDocuments -> Nothing+ Exts.MagicHash -> Just TH.MagicHash+ Exts.BinaryLiterals -> Just TH.BinaryLiterals+ Exts.TypeFamilies -> Just TH.TypeFamilies+ Exts.StandaloneDeriving -> Just TH.StandaloneDeriving+ Exts.UnicodeSyntax -> Just TH.UnicodeSyntax+ Exts.UnliftedFFITypes -> Just TH.UnliftedFFITypes+ Exts.LiberalTypeSynonyms -> Just TH.LiberalTypeSynonyms+ Exts.TypeOperators -> Just TH.TypeOperators+ Exts.ParallelArrays -> Just TH.ParallelArrays+ Exts.RecordWildCards -> Just TH.RecordWildCards+#if __GLASGOW_HASKELL__ >= 904+ Exts.RecordPuns -> Just TH.NamedFieldPuns+#else+ Exts.RecordPuns -> Just TH.RecordPuns+#endif+ Exts.DisambiguateRecordFields -> Just TH.DisambiguateRecordFields+ Exts.OverloadedStrings -> Just TH.OverloadedStrings+ Exts.GADTs -> Just TH.GADTs+ Exts.MonoPatBinds ->+#if !MIN_VERSION_template_haskell(2,18,0)+ Just TH.MonoPatBinds+#else+ Nothing+#endif+ Exts.RelaxedPolyRec -> Just TH.RelaxedPolyRec+ Exts.ExtendedDefaultRules -> Just TH.ExtendedDefaultRules+ Exts.UnboxedTuples -> Just TH.UnboxedTuples+ Exts.DeriveDataTypeable -> Just TH.DeriveDataTypeable+ Exts.ConstrainedClassMethods -> Just TH.ConstrainedClassMethods+ Exts.PackageImports -> Just TH.PackageImports+ Exts.LambdaCase -> Just TH.LambdaCase+ Exts.EmptyCase -> Just TH.EmptyCase+ Exts.ImpredicativeTypes -> Just TH.ImpredicativeTypes+ Exts.NewQualifiedOperators -> Nothing+ Exts.PostfixOperators -> Just TH.PostfixOperators+ Exts.QuasiQuotes -> Just TH.QuasiQuotes+ Exts.TransformListComp -> Just TH.TransformListComp+ Exts.ViewPatterns -> Just TH.ViewPatterns+ Exts.XmlSyntax -> Nothing+ Exts.RegularPatterns -> Nothing+ Exts.TupleSections -> Just TH.TupleSections+ Exts.GHCForeignImportPrim -> Just TH.GHCForeignImportPrim+ Exts.NPlusKPatterns -> Just TH.NPlusKPatterns+ Exts.DoAndIfThenElse -> Just TH.DoAndIfThenElse+ Exts.RebindableSyntax -> Just TH.RebindableSyntax+ Exts.ExplicitForAll -> Just TH.ExplicitForAll+ Exts.DatatypeContexts -> Just TH.DatatypeContexts+ Exts.MonoLocalBinds -> Just TH.MonoLocalBinds+ Exts.DeriveFunctor -> Just TH.DeriveFunctor+ Exts.DeriveGeneric -> Just TH.DeriveGeneric+ Exts.DeriveTraversable -> Just TH.DeriveTraversable+ Exts.DeriveFoldable -> Just TH.DeriveFoldable+ Exts.NondecreasingIndentation -> Just TH.NondecreasingIndentation+ Exts.InterruptibleFFI -> Just TH.InterruptibleFFI+ Exts.CApiFFI -> Just TH.CApiFFI+ Exts.JavaScriptFFI -> Just TH.JavaScriptFFI+ Exts.ExplicitNamespaces -> Just TH.ExplicitNamespaces+ Exts.DataKinds -> Just TH.DataKinds+ Exts.PolyKinds -> Just TH.PolyKinds+ Exts.MultiWayIf -> Just TH.MultiWayIf+ Exts.SafeImports -> Nothing+ Exts.Safe -> Nothing+ Exts.Trustworthy -> Nothing+ Exts.DefaultSignatures -> Just TH.DefaultSignatures+ Exts.ConstraintKinds -> Just TH.ConstraintKinds+ Exts.RoleAnnotations -> Just TH.RoleAnnotations+ Exts.PatternSynonyms -> Just TH.PatternSynonyms+ Exts.PartialTypeSignatures -> Just TH.PartialTypeSignatures+ Exts.NamedWildCards -> Just TH.NamedWildCards+ Exts.TypeApplications -> Just TH.TypeApplications+ Exts.TypeFamilyDependencies -> Just TH.TypeFamilyDependencies+ Exts.OverloadedLabels -> Just TH.OverloadedLabels+ Exts.DerivingStrategies -> Just TH.DerivingStrategies+ Exts.UnboxedSums -> Just TH.UnboxedSums+#if MIN_VERSION_haskell_src_exts(1,21,0)+ Exts.TypeInType -> Just TH.TypeInType+#endif+ Exts.Strict -> Just TH.Strict+ Exts.StrictData -> Just TH.StrictData++#if MIN_VERSION_haskell_src_exts(1,21,0)+ Exts.DerivingVia ->+#if MIN_VERSION_template_haskell(2,14,0)+ Just TH.DerivingVia+#else+ Nothing+#endif+#endif++#if MIN_VERSION_haskell_src_exts(1,22,0)+ Exts.QuantifiedConstraints ->+#if MIN_VERSION_template_haskell(2,14,0)+ Just TH.QuantifiedConstraints+#else+ Nothing+#endif+#endif++#if MIN_VERSION_haskell_src_exts(1,23,0)+ Exts.BlockArguments ->+#if MIN_VERSION_template_haskell(2,14,0)+ Just TH.BlockArguments+#else+ Nothing+#endif+#endif++#if MIN_VERSION_haskell_src_exts(1,24,0)+ Exts.ImportQualifiedPost ->+#if MIN_VERSION_template_haskell(2,16,0)+ Just TH.ImportQualifiedPost+#else+ Nothing+#endif+#endif++ -- NB: when adding a case here, you may also need to update `fromExtension`+++-----------------------------------------------------------------------------++-- * From template-haskell++-- | Returns @Nothing@ when the extension is not supported by haskell-src-exts.+fromExtension :: TH.Extension -> Maybe Exts.KnownExtension+fromExtension e = case e of+ TH.Cpp -> Just Exts.CPP+ TH.OverlappingInstances -> Just Exts.OverlappingInstances+ TH.UndecidableInstances -> Just Exts.UndecidableInstances+ TH.IncoherentInstances -> Just Exts.IncoherentInstances+ TH.UndecidableSuperClasses -> Nothing+ TH.MonomorphismRestriction -> Just Exts.MonomorphismRestriction+#if !MIN_VERSION_template_haskell(2,18,0)+ TH.MonoPatBinds -> Just Exts.MonoPatBinds+#endif+ TH.MonoLocalBinds -> Just Exts.MonoLocalBinds+ TH.RelaxedPolyRec -> Just Exts.RelaxedPolyRec+ TH.ExtendedDefaultRules -> Just Exts.ExtendedDefaultRules+ TH.ForeignFunctionInterface -> Just Exts.ForeignFunctionInterface+ TH.UnliftedFFITypes -> Just Exts.UnliftedFFITypes+ TH.InterruptibleFFI -> Just Exts.InterruptibleFFI+ TH.CApiFFI -> Just Exts.CApiFFI+ TH.GHCForeignImportPrim -> Just Exts.GHCForeignImportPrim+ TH.JavaScriptFFI -> Just Exts.JavaScriptFFI+ TH.ParallelArrays -> Just Exts.ParallelArrays+ TH.Arrows -> Just Exts.Arrows+ TH.TemplateHaskell -> Just Exts.TemplateHaskell+ TH.TemplateHaskellQuotes -> Nothing+ TH.QuasiQuotes -> Just Exts.QuasiQuotes+ TH.ImplicitParams -> Just Exts.ImplicitParams+ TH.ImplicitPrelude -> Just Exts.ImplicitPrelude+ TH.ScopedTypeVariables -> Just Exts.ScopedTypeVariables+ TH.AllowAmbiguousTypes -> Nothing+ TH.UnboxedTuples -> Just Exts.UnboxedTuples+ TH.UnboxedSums -> Just Exts.UnboxedSums+ TH.BangPatterns -> Just Exts.BangPatterns+ TH.TypeFamilies -> Just Exts.TypeFamilies+ TH.TypeFamilyDependencies -> Just Exts.TypeFamilyDependencies+ TH.TypeInType ->+#if MIN_VERSION_haskell_src_exts(1,21,0)+ Just Exts.TypeInType+#else+ Nothing+#endif+ TH.OverloadedStrings -> Just Exts.OverloadedStrings+ TH.OverloadedLists -> Nothing+ TH.NumDecimals -> Nothing+ TH.DisambiguateRecordFields -> Just Exts.DisambiguateRecordFields+ TH.RecordWildCards -> Just Exts.RecordWildCards+#if __GLASGOW_HASKELL__ >= 904+ TH.NamedFieldPuns -> Just Exts.RecordPuns+ TH.QualifiedDo -> Nothing+ TH.UnliftedDatatypes -> Nothing+ TH.LinearTypes -> Nothing+ TH.LexicalNegation -> Nothing+ TH.FieldSelectors -> Nothing+ TH.OverloadedRecordDot -> Nothing+ TH.OverloadedRecordUpdate -> Nothing+#else+ TH.RecordPuns -> Just Exts.RecordPuns+#endif+ TH.ViewPatterns -> Just Exts.ViewPatterns+ TH.GADTs -> Just Exts.GADTs+ TH.GADTSyntax -> Nothing+ TH.NPlusKPatterns -> Just Exts.NPlusKPatterns+ TH.DoAndIfThenElse -> Just Exts.DoAndIfThenElse+ TH.RebindableSyntax -> Just Exts.RebindableSyntax+ TH.ConstraintKinds -> Just Exts.ConstraintKinds+ TH.PolyKinds -> Just Exts.PolyKinds+ TH.DataKinds -> Just Exts.DataKinds+ TH.InstanceSigs -> Just Exts.InstanceSigs+ TH.ApplicativeDo -> Nothing+ TH.StandaloneDeriving -> Just Exts.StandaloneDeriving+ TH.DeriveDataTypeable -> Just Exts.DeriveDataTypeable+ TH.AutoDeriveTypeable -> Nothing+ TH.DeriveFunctor -> Just Exts.DeriveFunctor+ TH.DeriveTraversable -> Just Exts.DeriveTraversable+ TH.DeriveFoldable -> Just Exts.DeriveFoldable+ TH.DeriveGeneric -> Just Exts.DeriveGeneric+ TH.DefaultSignatures -> Just Exts.DefaultSignatures+ TH.DeriveAnyClass -> Just Exts.DeriveAnyClass+ TH.DeriveLift -> Nothing+ TH.DerivingStrategies -> Just Exts.DerivingStrategies+ TH.TypeSynonymInstances -> Just Exts.TypeSynonymInstances+ TH.FlexibleContexts -> Just Exts.FlexibleContexts+ TH.FlexibleInstances -> Just Exts.FlexibleInstances+ TH.ConstrainedClassMethods -> Just Exts.ConstrainedClassMethods+ TH.MultiParamTypeClasses -> Just Exts.MultiParamTypeClasses+ TH.NullaryTypeClasses -> Nothing+ TH.FunctionalDependencies -> Just Exts.FunctionalDependencies+ TH.UnicodeSyntax -> Just Exts.UnicodeSyntax+ TH.ExistentialQuantification -> Just Exts.ExistentialQuantification+ TH.MagicHash -> Just Exts.MagicHash+ TH.EmptyDataDecls -> Just Exts.EmptyDataDecls+ TH.KindSignatures -> Just Exts.KindSignatures+ TH.RoleAnnotations -> Just Exts.RoleAnnotations+ TH.ParallelListComp -> Just Exts.ParallelListComp+ TH.TransformListComp -> Just Exts.TransformListComp+ TH.MonadComprehensions -> Nothing+ TH.GeneralizedNewtypeDeriving -> Just Exts.GeneralizedNewtypeDeriving+ TH.RecursiveDo -> Just Exts.RecursiveDo+ TH.PostfixOperators -> Just Exts.PostfixOperators+ TH.TupleSections -> Just Exts.TupleSections+ TH.PatternGuards -> Just Exts.PatternGuards+ TH.LiberalTypeSynonyms -> Just Exts.LiberalTypeSynonyms+ TH.RankNTypes -> Just Exts.RankNTypes+ TH.ImpredicativeTypes -> Just Exts.ImpredicativeTypes+ TH.TypeOperators -> Just Exts.TypeOperators+ TH.ExplicitNamespaces -> Just Exts.ExplicitNamespaces+ TH.PackageImports -> Just Exts.PackageImports+ TH.ExplicitForAll -> Just Exts.ExplicitForAll+ TH.AlternativeLayoutRule -> Nothing+ TH.AlternativeLayoutRuleTransitional -> Nothing+ TH.DatatypeContexts -> Just Exts.DatatypeContexts+ TH.NondecreasingIndentation -> Just Exts.NondecreasingIndentation+ TH.RelaxedLayout -> Nothing+ TH.TraditionalRecordSyntax -> Nothing+ TH.LambdaCase -> Just Exts.LambdaCase+ TH.MultiWayIf -> Just Exts.MultiWayIf+ TH.BinaryLiterals -> Just Exts.BinaryLiterals+ TH.NegativeLiterals -> Nothing+ TH.DuplicateRecordFields -> Nothing+ TH.OverloadedLabels -> Just Exts.OverloadedLabels+ TH.EmptyCase -> Just Exts.EmptyCase+ TH.PatternSynonyms -> Just Exts.PatternSynonyms+ TH.PartialTypeSignatures -> Just Exts.PartialTypeSignatures+ TH.NamedWildCards -> Just Exts.NamedWildCards+ TH.StaticPointers -> Nothing+ TH.TypeApplications -> Just Exts.TypeApplications+ TH.Strict -> Just Exts.Strict+ TH.StrictData -> Just Exts.StrictData+#if !MIN_VERSION_template_haskell(2,18,0)+ TH.MonadFailDesugaring -> Nothing+#endif++-- 2.13.0 ----------------------------------------+#if MIN_VERSION_template_haskell(2,13,0)+ TH.HexFloatLiterals -> Nothing+ TH.EmptyDataDeriving -> Nothing+#endif++-- 2.14.0 ----------------------------------------+#if MIN_VERSION_template_haskell(2,14,0)++ TH.DerivingVia ->+#if MIN_VERSION_haskell_src_exts(1,21,0)+ Just Exts.DerivingVia+#else+ Nothing+#endif++ TH.QuantifiedConstraints ->+#if MIN_VERSION_haskell_src_exts(1,22,0)+ Just Exts.QuantifiedConstraints+#else+ Nothing+#endif++ TH.BlockArguments ->+#if MIN_VERSION_haskell_src_exts(1,23,0)+ Just Exts.BlockArguments+#else+ Nothing+#endif++ TH.NumericUnderscores -> Nothing+ TH.StarIsType -> Nothing+#endif++-- 2.16.0 ----------------------------------------+#if MIN_VERSION_template_haskell(2,16,0)+ TH.UnliftedNewtypes -> Nothing+ TH.CUSKs -> Nothing+ TH.StandaloneKindSignatures -> Nothing+ TH.ImportQualifiedPost ->+#if MIN_VERSION_haskell_src_exts(1,24,0)+ Just Exts.ImportQualifiedPost+#else+ Nothing+#endif+#endif++-- 2.19.0 ---------------------------------------++#if MIN_VERSION_template_haskell(2,19,0)+ TH.DeepSubsumption -> Nothing+#endif++-- 2.20.0 ---------------------------------------++#if MIN_VERSION_template_haskell(2,20,0)+ TH.TypeData -> Nothing+#endif++-- 2.21.0 ---------------------------------------++#if MIN_VERSION_template_haskell(2,21,0)+ TH.TypeAbstractions -> Nothing+ TH.ExtendedLiterals -> Nothing+#endif++-- 2.22.0 ---------------------------------------++#if MIN_VERSION_template_haskell(2,22,0)+ TH.RequiredTypeArguments -> Nothing+ TH.ListTuplePuns -> Nothing+#endif++-- 2.23.0 ---------------------------------------++#if MIN_VERSION_template_haskell(2,23,0)+ TH.MultilineStrings -> Nothing+ TH.NamedDefaults -> Nothing+ TH.OrPatterns -> Nothing+#endif++#if MIN_VERSION_template_haskell(2,24,0)+ TH.ExplicitLevelImports -> Nothing+ TH.ImplicitStagePersistence -> Nothing+#endif++ -- NB: when adding a case here, you may also need to update `toExtension`+++-----------------------------------------------------------------------------
src/Language/Haskell/Meta/Parse.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE CPP #-} {- | Module : Language.Haskell.Meta.Parse Copyright : (c) Matt Morrow 2008@@ -8,43 +8,69 @@ Portability : portable (template-haskell) -} -module Language.Haskell.Meta.Parse where+module Language.Haskell.Meta.Parse (+ parsePat,+ parseExp,+ parseType,+ parseDecs,+ parseDecsWithMode,+ myDefaultParseMode,+ myDefaultExtensions,+ parseResultToEither,+ parseHsModule,+ parseHsDecls,+ parseHsDeclsWithMode,+ parseHsType,+ parseHsExp,+ parseHsPat,+ pprHsModule,+ moduleDecls,+ noSrcSpanInfo,+ emptyHsModule+ ) where -import Language.Haskell.TH.Syntax-import Language.Haskell.Meta.Syntax-import qualified Language.Haskell.Exts.Syntax as Hs-import Language.Haskell.Exts.Annotated.Fixity-import Language.Haskell.Exts.Extension-import Language.Haskell.Exts.Parser-import Language.Haskell.Exts.Pretty+import Language.Haskell.Exts.Extension+import Language.Haskell.Exts.Parser hiding+ (parseExp, parsePat, parseType)+import Language.Haskell.Exts.Pretty+import qualified Language.Haskell.Exts.SrcLoc as Hs+import qualified Language.Haskell.Exts.Syntax as Hs+import Language.Haskell.Meta.Syntax.Translate+import Language.Haskell.TH.Syntax hiding (Extension (..)) ----------------------------------------------------------------------------- -- * template-haskell parsePat :: String -> Either String Pat-parsePat = either Left (Right . toPat) . parseHsPat+parsePat = fmap toPat . parseHsPat parseExp :: String -> Either String Exp-parseExp = either Left (Right . toExp) . parseHsExp+parseExp = fmap toExp . parseHsExp parseType :: String -> Either String Type-parseType = either Left (Right . toType) . parseHsType+parseType = fmap toType . parseHsType parseDecs :: String -> Either String [Dec]-parseDecs = either Left (Right . toDecs) . parseHsDecls+parseDecs = fmap toDecs . parseHsDecls +-- | @since 0.8.2+parseDecsWithMode :: ParseMode -> String -> Either String [Dec]+parseDecsWithMode parseMode = fmap toDecs+ . parseHsDeclsWithMode parseMode+ ----------------------------------------------------------------------------- +{-# DEPRECATED myDefaultParseMode, myDefaultExtensions+ "The provided ParseModes aren't very meaningful, use your own instead" #-} myDefaultParseMode :: ParseMode-myDefaultParseMode = ParseMode+myDefaultParseMode = defaultParseMode {parseFilename = []- ,extensions = myDefaultExtensions- ,ignoreLinePragmas = False- ,ignoreLanguagePragmas = False- ,fixities = baseFixities}+ ,baseLanguage = Haskell2010+ ,extensions = map EnableExtension myDefaultExtensions+ } -myDefaultExtensions :: [Extension]+myDefaultExtensions :: [KnownExtension] myDefaultExtensions = [PostfixOperators ,QuasiQuotes ,UnicodeSyntax@@ -54,7 +80,8 @@ ,TemplateHaskell ,RankNTypes ,MultiParamTypeClasses- ,RecursiveDo]+ ,RecursiveDo+ ,TypeApplications] parseResultToEither :: ParseResult a -> Either String a parseResultToEither (ParseOk a) = Right a@@ -62,47 +89,54 @@ = let line = Hs.srcLine loc - 1 in Left (unlines [show line,show loc,e]) -parseHsModule :: String -> Either String Hs.Module+parseHsModule :: String -> Either String (Hs.Module Hs.SrcSpanInfo) parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode -parseHsDecls :: String -> Either String [Hs.Decl]-parseHsDecls = either Left (Right . moduleDecls)+parseHsDecls :: String -> Either String [Hs.Decl Hs.SrcSpanInfo]+parseHsDecls = fmap moduleDecls . parseResultToEither . parseModuleWithMode myDefaultParseMode +-- | @since 0.8.2+parseHsDeclsWithMode :: ParseMode -> String -> Either String [Hs.Decl Hs.SrcSpanInfo]+parseHsDeclsWithMode parseMode = fmap moduleDecls+ . parseResultToEither . parseModuleWithMode parseMode -parseHsType :: String -> Either String Hs.Type++parseHsType :: String -> Either String (Hs.Type Hs.SrcSpanInfo) parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode -parseHsExp :: String -> Either String Hs.Exp+parseHsExp :: String -> Either String (Hs.Exp Hs.SrcSpanInfo) parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode -parseHsPat :: String -> Either String Hs.Pat+parseHsPat :: String -> Either String (Hs.Pat Hs.SrcSpanInfo) parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode -pprHsModule :: Hs.Module -> String+pprHsModule :: Hs.Module Hs.SrcSpanInfo -> String pprHsModule = prettyPrint -moduleDecls :: Hs.Module -> [Hs.Decl]-moduleDecls (Hs.Module _ _ _ _ _ _ x) = x+moduleDecls :: Hs.Module Hs.SrcSpanInfo -> [Hs.Decl Hs.SrcSpanInfo]+moduleDecls (Hs.Module _ _ _ _ x) = x+moduleDecls m = todo "" m+-- TODO+-- (Hs.XmlPage _ _ _ _ _ _ _)+-- (Hs.XmlHybrid _ _ _ _ _ _ _ _ _) -- mkModule :: String -> Hs.Module -- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] [] -emptySrcLoc :: Hs.SrcLoc-emptySrcLoc = (Hs.SrcLoc [] 0 0)--emptyHsModule :: String -> Hs.Module+emptyHsModule :: String -> Hs.Module Hs.SrcSpanInfo emptyHsModule n = (Hs.Module- emptySrcLoc- (Hs.ModuleName n)+ noSrcSpanInfo+ (Just (Hs.ModuleHead noSrcSpanInfo (Hs.ModuleName noSrcSpanInfo n) Nothing Nothing)) []- Nothing- Nothing [] [])++noSrcSpanInfo :: Hs.SrcSpanInfo+noSrcSpanInfo = Hs.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc) {- ghci> :i Module
− src/Language/Haskell/Meta/QQ/BF.hs
@@ -1,182 +0,0 @@-{-# LANGUAGE BangPatterns, TemplateHaskell #-}--module Language.Haskell.Meta.QQ.BF (- bf,bf2,bfHelloWorld-) where--import Language.Haskell.Meta-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax--import Data.Char-import Data.IntMap(IntMap)-import qualified Data.IntMap as IM---bf :: QuasiQuoter-bf = QuasiQuoter bfExpQ bfPatQ--bf2 :: QuasiQuoter-bf2 = QuasiQuoter bf2ExpQ bfPatQ--bf2ExpQ :: String -> ExpQ-bf2ExpQ s = [|eval (parse s)|]--bfExpQ :: String -> ExpQ-bfExpQ s = [|eval_ (parse s)|]--bfPatQ :: String -> PatQ-bfPatQ s = do- let p = (parsePat- . show- . parse) s- case p of- Left e -> fail e- Right p -> return p--instance Lift Bf where- lift Inp = [|Inp|]- lift Out = [|Out|]- lift Inc = [|Inc|]- lift Dec = [|Dec|]- lift MovL = [|MovL|]- lift MovR = [|MovR|]- lift (While xs) = [|While $(lift xs)|]--type Ptr = Int-newtype Mem = Mem (IntMap Int) deriving (Show)--data Bf = Inp- | Out- | Inc- | Dec- | MovL- | MovR- | While [Bf]- deriving (Eq,Ord,Read,Show)--data Status = D Ptr Mem- | W Int Status- | R (Int -> Status)---- ghci> exec (parse helloWorld)--- Hello World!--- (4,Mem (fromList [(0,0),(1,87),(2,100),(3,33),(4,10)]))-bfHelloWorld :: String-bfHelloWorld = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."--eval_ :: [Bf] -> (String -> String)-eval_ is = go (run 0 initMem is)- where go (D p m) _ = []- go (W n s) cs = chr n : go s cs- go (R cont) [] = "*** Exception: bf blocked on input"- go (R cont) (c:cs) = go ((cont . ord) c) cs--eval :: [Bf] -> String -> (String, (Ptr, Mem))-eval is = go [] (run 0 initMem is)- where go acc (D p m) _ = (reverse acc, (p, m))- go acc (W n s) cs = go (chr n:acc) s cs- go _ (R cont) [] = ("*** Exception: bf blocked on input",(-1, Mem IM.empty))- go acc (R cont) (c:cs) = go acc ((cont . ord) c) cs--exec :: [Bf] -> IO (Ptr, Mem)-exec is = go (run 0 initMem is)- where go (D p m) = return (p, m)- go (W n s) = putChar (chr n) >> go s- go (R cont) = go . cont . ord =<< getChar--run :: Ptr -> Mem -> [Bf] -> Status-run dp m is = step dp m is (\dp m -> D dp m)--step :: Ptr -> Mem -> [Bf] -> (Ptr -> Mem -> Status) -> Status-step dp m [] k = k dp m-step dp m (Inc:is) k = step dp (inc dp m) is k-step dp m (Dec:is) k = step dp (dec dp m) is k-step dp m (MovL:is) k = step (dp-1) m is k-step dp m (MovR:is) k = step (dp+1) m is k-step dp m (Inp:is) k = R (\c -> step dp (wr m dp c) is k)-step dp m (Out:is) k = W (rd m dp) (step dp m is k)-step dp m (While xs:is) k = let go dp m = if rd m dp == 0- then step dp m is k- else step dp m xs go- in go dp m--initMem :: Mem-initMem = Mem IM.empty--inc :: Ptr -> (Mem -> Mem)-dec :: Ptr -> (Mem -> Mem)-rd :: Mem -> Ptr -> Int-wr :: Mem -> Ptr -> Int -> Mem-upd :: Mem -> Ptr -> (Int -> Int) -> Mem-inc p m = upd m p (+1)-dec p m = upd m p (subtract 1)-rd (Mem m) p = maybe 0 id (IM.lookup p m)-wr (Mem m) p n = Mem (IM.insert p n m)-upd m p f = wr m p (f (rd m p))--parse :: String -> [Bf]-parse s = go 0 [] s (\_ xs _ -> xs)- where go :: Int -> [Bf] -> String- -> (Int -> [Bf] -> String -> o) -> o- go !n acc [] k = k n (reverse acc) []- go !n acc (',':cs) k = go (n+1) (Inp:acc) cs k- go !n acc ('.':cs) k = go (n+1) (Out:acc) cs k- go !n acc ('+':cs) k = go (n+1) (Inc:acc) cs k- go !n acc ('-':cs) k = go (n+1) (Dec:acc) cs k- go !n acc ('<':cs) k = go (n+1) (MovL:acc) cs k- go !n acc ('>':cs) k = go (n+1) (MovR:acc) cs k- go !n acc ('[':cs) k = go (n+1) [] cs (\n xs cs ->- go n (While xs:acc) cs k)- go !n acc (']':cs) k = k (n+1) (reverse acc) cs- go !n acc (c :cs) k = go n acc cs k----test0 = do- a <- readFile "prime.bf"- return (parse a)--------{--data Bf = Inp- | Out- | Inc- | Dec- | MovL- | MovR- | While [Bf]- | Error String- deriving (Eq,Ord,Read,Show)--parse :: String -> [Bf]-parse s = let p n s = case go n [] s of- (_,xs,[]) -> xs- (n,xs, s) -> xs ++ p n s- in p 0 s- where go :: Int -> [Bf] -> [Char] -> (Int, [Bf], String)- go !n acc [] = (n, reverse acc, [])- go !n acc (',':cs) = go (n+1) (Inp:acc) cs- go !n acc ('.':cs) = go (n+1) (Out:acc) cs- go !n acc ('+':cs) = go (n+1) (Inc:acc) cs- go !n acc ('-':cs) = go (n+1) (Dec:acc) cs- go !n acc ('<':cs) = go (n+1) (MovL:acc) cs- go !n acc ('>':cs) = go (n+1) (MovR:acc) cs- go !n acc ('[':cs) = case go (n+1) [] cs of- (n,xs,cs) -> go n (While xs:acc) cs- go !n acc (']':cs) = (n+1, reverse acc, cs)- go !n acc (c :cs) = (n+1, [Error ("go error: char "++show n- ++" illegal character: "++show c)], [])--}------
− src/Language/Haskell/Meta/QQ/Here.hs
@@ -1,10 +0,0 @@---- | Here!--module Language.Haskell.Meta.QQ.Here (here) where--import Language.Haskell.TH.Quote-import Language.Haskell.TH.Lib--here :: QuasiQuoter-here = QuasiQuoter (litE . stringL) (litP . stringL)
− src/Language/Haskell/Meta/QQ/Hs.hs
@@ -1,34 +0,0 @@----- | Eat your face!--module Language.Haskell.Meta.QQ.Hs (hs, pat) where--import Language.Haskell.Meta-import Language.Haskell.Meta.Utils-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax---- |--- > ghci> [$hs|\x -> (x,x)|] 42--- > (42,42)--- > ghci> (\[$hs|a@(x,_)|] -> (a,x)) (42,88)--- > ((42,88),42)-hs :: QuasiQuoter-hs = QuasiQuoter- (either fail transformE . parseExp)- (either fail transformP . parsePat)--transformE :: Exp -> ExpQ-transformE = return--transformP :: Pat -> PatQ-transformP = return--pat :: QuasiQuoter-pat = QuasiQuoter- (quoteExp hs)- (\s -> case parseExp s of- Left err -> fail err- Right e -> either fail return (parsePat . pretty $ e))
− src/Language/Haskell/Meta/QQ/HsHere.hs
@@ -1,106 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}--module Language.Haskell.Meta.QQ.HsHere (here) where--import Language.Haskell.Meta-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.Meta.Utils-import Text.ParserCombinators.ReadP-import Data.Typeable(Typeable)-import Data.Generics(Data)--data Here- = CodeH Exp- | TextH String- | ManyH [Here]- deriving (Eq,Show,Data,Typeable)--here :: QuasiQuoter-here = QuasiQuoter- {quoteExp = hereExpQ- ,quotePat = herePatQ}--instance Lift Here- where lift = liftHere--liftHere :: Here -> ExpQ-liftHere (TextH s) = (litE . stringL) s-liftHere (CodeH e) = [|show $(return e)|]-liftHere (ManyH hs) = [|concat $(listE (fmap liftHere hs))|]---hereExpQ :: String -> ExpQ-hereExpQ s = case run s of- [] -> fail "here: parse error"- e:_ -> lift (cleanNames e)--herePatQ :: String -> PatQ-herePatQ s = do- e <- hereExpQ s- let p = (parsePat- . pprint- . cleanNames) e- case p of- Left e -> fail e- Right p -> return p--run :: String -> [Here]-run = fst . parse--parse :: String -> ([Here], String)-parse = runP hereP--hereP :: ReadP Here-hereP = (ManyH . mergeTexts)- `fmap` many (oneP =<< look)--mergeTexts :: [Here] -> [Here]-mergeTexts [] = []-mergeTexts (TextH s:TextH t:hs)- = mergeTexts (TextH (s++t):hs)-mergeTexts (h:hs) = h : mergeTexts hs--oneP :: String -> ReadP Here-oneP s- | [] <- s = pfail- | '\\':'$':s <- s = do skip 2- (TextH . ("\\$"++))- `fmap` munch (/='\\')- | '$':'(':s <- s = skip 2 >> go 1 [] s- | c:s <- s = do skip 1- (TextH . (c:))- `fmap` munch (not.(`elem`"\\$"))- where go _ acc [] = return (TextH (reverse acc))- go 1 [] (')':_) = skip 1 >> return (TextH "$()")- go 1 acc (')':_) = do skip (1 + length acc)- let s = reverse acc- either (const (return- (TextH s)))- (return . CodeH)- (parseExp s)- go n acc ('(':s) = go (n+1) ('(':acc) s- go n acc (')':s) = go (n-1) (')':acc) s- go n acc (c:s) = go n (c:acc) s---runP :: ReadP a -> String -> ([a], String)-runP p s = case readP_to_S p s of- [] -> ([],[])- xs -> mapfst (:[]) (last xs)- where mapfst f (a,b) = (f a,b)-skip :: Int -> ReadP ()-skip n = count n get >> return ()-lexemeP :: ReadP a -> ReadP a-lexemeP p = p >>= \x -> skipSpaces >> return x-nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)-nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)-parensP = between oparenP cparenP-bracksP = between oparenP cparenP-oparenP = char '('-cparenP = char ')'-obrackP = char '['-cbrackP = char ']'-
− src/Language/Haskell/Meta/QQ/Idiom.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}---- | Idiom brackets. Vixey's idea.--module Language.Haskell.Meta.QQ.Idiom (i) where--import Data.Generics- (Data,everywhere,mkT)-import Control.Applicative-import Language.Haskell.Meta-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax---- ghci> [$i| (,) "foo" "bar" |]--- [('f','b'),('f','a'),('f','r'),('o','b'),('o','a'),('o','r'),('o','b'),('o','a'),('o','r')]-i :: QuasiQuoter-i = QuasiQuoter ((cleanNames <$>) . applicateQ)- (either fail return . parsePat)--applicateQ :: String -> ExpQ-applicateQ s = case either fail unwindE (parseExp s) of- x:y:xs -> foldl- (\e e' -> [|$e <*> $e'|])- [|$(return x) <$> $(return y)|]- (fmap return xs)- _ -> fail "applicateQ fails."--unwindE :: Exp -> [Exp]-unwindE = go []- where go acc (e `AppE` e') = go (e':acc) e- go acc e = e:acc--cleanNames :: (Data a) => a -> a-cleanNames = everywhere (mkT cleanName)- where cleanName :: Name -> Name- cleanName n- | isNameU n = n- | otherwise = (mkName . nameBase) n- isNameU :: Name -> Bool- isNameU (Name _ (NameU _)) = True- isNameU _ = False--
− src/Language/Haskell/Meta/QQ/SKI.hs
@@ -1,155 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}--module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where--import Language.Haskell.Meta-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.Meta.Utils-import Text.ParserCombinators.ReadP-import Data.Typeable(Typeable)-import Data.Generics(Data)-import Text.PrettyPrint(render)--data SKI = S | K | I | E Exp | SKI :$ SKI- deriving (Eq,Data,Typeable)--run :: String -> [SKI]-run = fmap eval . fst . parse---- I x = x--- K x y = x--- S x y z = (x z) (y z)-eval :: SKI -> SKI-eval (I :$ x) = eval x-eval ((K :$ x) :$ y) = eval x-eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))-eval (E e :$ E e') = E (unQ[|$(return e) $(return e')|])-eval (x :$ y) = eval0 ((eval x) :$ (eval y))-eval x = x-eval0 (I :$ x) = eval x-eval0 ((K :$ x) :$ y) = eval x-eval0 (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))-eval0 (E e :$ E e') = E (unQ[|$(return e) $(return e')|])-eval0 x = x--ski :: QuasiQuoter-ski = QuasiQuoter- {quoteExp = skiExpQ- ,quotePat = skiPatQ}--instance Lift SKI where- lift = liftSKI--liftSKI (E e) = return e-liftSKI a = go a- where go S = [|S|]- go K = [|K|]- go I = [|I|]- go (E e) = [|E e|]- go (x:$y) = [|$(go x) :$ $(go y)|]--instance Show SKI where- showsPrec p (S) = showString "S"- showsPrec p (K) = showString "K"- showsPrec p (I) = showString "I"- showsPrec p (E x1)- = showParen (p > 10)- (showString (render (ppDoc x1)))- showsPrec p ((:$) x1 x2)- = showParen (p > 10)- (showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2))--skiExpQ :: String -> ExpQ-skiExpQ s = case run s of- [] -> fail "ski: parse error"- e:_ -> lift (cleanNames e)--skiPatQ :: String -> PatQ-skiPatQ s = do- e <- skiExpQ s- let p = (parsePat- . pprint- . cleanNames) e- case p of- Left e -> fail e- Right p -> return p---- ghci> parse "S(SS)IK(SK)"--- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"")-parse :: String -> ([SKI], String)-parse = runP skiP--skiP :: ReadP SKI-skiP = nestedP parensP- (let go a = (do b <- lexemeP (oneP <++ skiP)- go (a:$b)) <++ return a- in lexemeP (go =<< lexemeP oneP))--oneP :: ReadP SKI-oneP = nestedP parensP- (lexemeP (choice [sP- ,kP- ,iP- ,spliceP =<< look- ]))--spliceP :: String -> ReadP SKI-spliceP s- | '[':s <- s = skip 1 >> go 1 [] s- | otherwise = pfail- where go _ _ [] = pfail- go 1 acc (']':_) = do skip (1 + length acc)- either (const pfail)- (return . E)- (parseExp (reverse acc))- go n acc ('[':s) = go (n+1) ('[':acc) s- go n acc (']':s) = go (n-1) (']':acc) s- go n acc (c:s) = go n (c:acc) s----sP = (char 's' +++ char 'S') >> return S-kP = (char 'k' +++ char 'K') >> return K-iP = (char 'i' +++ char 'I') >> return I--runP :: ReadP a -> String -> ([a], String)-runP p s = case readP_to_S p s of- [] -> ([],[])- xs -> mapfst (:[]) (last xs)- where mapfst f (a,b) = (f a,b)-skip :: Int -> ReadP ()-skip n = count n get >> return ()-lexemeP :: ReadP a -> ReadP a-lexemeP p = p >>= \x -> skipSpaces >> return x-nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)-nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)-parensP = between oparenP cparenP-bracksP = between oparenP cparenP-oparenP = char '('-cparenP = char ')'-obrackP = char '['-cbrackP = char ']'-----{--import Prelude hiding (($))-data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show-S Nothing $ x = S (Just (x, Nothing))-S (Just (x, Nothing)) $ y = S (Just (x, Just y))-S (Just (x, Just y)) $ z = x $ z $ (y $ z)-K Nothing $ x = K (Just x)-K (Just x) $ y = y-q x = x $ (c $ k) $ k $ k $ s- where s = S Nothing- k = K Nothing- c = s $ (b $ b $ s) $ k $ k- b = s $ (k $ s) $ k--}---
− src/Language/Haskell/Meta/Syntax.hs
@@ -1,19 +0,0 @@--{- |- Module : Language.Haskell.Meta.Syntax- Copyright : (c) Matt Morrow 2008- License : BSD3- Maintainer : Matt Morrow <mjm2002@gmail.com>- Stability : experimental- Portability : portable (template-haskell)--}--module Language.Haskell.Meta.Syntax (- module Language.Haskell.Meta.Syntax.Vars- , module Language.Haskell.Meta.Syntax.Translate-) where--import Language.Haskell.Meta.Syntax.Vars-import Language.Haskell.Meta.Syntax.Translate--
src/Language/Haskell/Meta/Syntax/Translate.hs view
@@ -1,602 +1,828 @@-{-# LANGUAGE TemplateHaskell, TypeSynonymInstances #-}--{- |- Module : Language.Haskell.Meta.Syntax.Translate- Copyright : (c) Matt Morrow 2008- License : BSD3- Maintainer : Matt Morrow <mjm2002@gmail.com>- Stability : experimental- Portability : portable (template-haskell)--}--module Language.Haskell.Meta.Syntax.Translate (- module Language.Haskell.Meta.Syntax.Translate-) where--import Data.Typeable-import Data.List (foldl', nub, (\\))-import Language.Haskell.TH.Syntax-import qualified Language.Haskell.Exts.Syntax as Hs----------------------------------------------------------------------------------class ToName a where toName :: a -> Name-class ToLit a where toLit :: a -> Lit-class ToType a where toType :: a -> Type-class ToPat a where toPat :: a -> Pat-class ToExp a where toExp :: a -> Exp-class ToDecs a where toDecs :: a -> [Dec]-class ToDec a where toDec :: a -> Dec-class ToStmt a where toStmt :: a -> Stmt-class ToLoc a where toLoc :: a -> Loc---errorMsg :: (Typeable a) => String -> a -> String-errorMsg fun a = concat- [ fun,": "- , show . typeRepTyCon . typeOf $ a- , " not (yet?) implemented"- ]-----------------------------------------------------------------------------------instance ToExp Lit where- toExp = LitE-instance (ToExp a) => ToExp [a] where- toExp = ListE . fmap toExp-instance (ToExp a, ToExp b) => ToExp (a,b) where- toExp (a,b) = TupE [toExp a, toExp b]-instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where- toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]-instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where- toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]---instance ToPat Lit where- toPat = LitP-instance (ToPat a) => ToPat [a] where- toPat = ListP . fmap toPat-instance (ToPat a, ToPat b) => ToPat (a,b) where- toPat (a,b) = TupP [toPat a, toPat b]-instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where- toPat (a,b,c) = TupP [toPat a, toPat b, toPat c]-instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where- toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d]---instance ToLit Char where- toLit = CharL-instance ToLit String where- toLit = StringL-instance ToLit Integer where- toLit = IntegerL-instance ToLit Int where- toLit = IntegerL . toInteger-instance ToLit Float where- toLit = RationalL . toRational-instance ToLit Double where- toLit = RationalL . toRational------------------------------------------------------------------------------------- * ToName {String,HsName,Module,HsSpecialCon,HsQName}---instance ToName String where- toName = mkName--instance ToName Hs.Name where- toName (Hs.Ident s) = toName s- toName (Hs.Symbol s) = toName s--instance ToName Hs.Module where- toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s---instance ToName Hs.SpecialCon where- toName Hs.UnitCon = '()- toName Hs.ListCon = '[]- toName Hs.FunCon = ''(->)- toName (Hs.TupleCon _ n)- | n<2 = '()- | otherwise =- let x = maybe [] (++".") (nameModule '())- in toName . concat $ x : ["(",replicate (n-1) ',',")"]- toName Hs.Cons = '(:)---instance ToName Hs.QName where--- toName (Hs.Qual (Hs.Module []) n) = toName n- toName (Hs.Qual (Hs.ModuleName []) n) = toName n- toName (Hs.Qual (Hs.ModuleName m) n) =- let m' = show . toName $ m- n' = show . toName $ n- in toName . concat $ [m',".",n']- toName (Hs.UnQual n) = toName n- toName (Hs.Special s) = toName s------------------------------------------------------------------------------------- * ToLit HsLiteral---instance ToLit Hs.Literal where- toLit (Hs.Char a) = CharL a- toLit (Hs.String a) = StringL a- toLit (Hs.Int a) = IntegerL a- toLit (Hs.Frac a) = RationalL a- toLit (Hs.PrimChar a) = CharL a -- XXX- toLit (Hs.PrimString a) = StringL a -- XXX- toLit (Hs.PrimInt a) = IntPrimL a- toLit (Hs.PrimWord a) = WordPrimL a- toLit (Hs.PrimFloat a) = FloatPrimL a- toLit (Hs.PrimDouble a) = DoublePrimL a------------------------------------------------------------------------------------ * ToPat HsPat---instance ToPat Hs.Pat where- toPat (Hs.PVar n)- = VarP (toName n)- toPat (Hs.PLit l)- = LitP (toLit l)-{--ghci> parseHsPat "-2"-Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))--}- toPat (Hs.PNeg p) = error "toPat: HsPNeg not supported"- toPat (Hs.PInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)- toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps)- toPat (Hs.PTuple ps) = TupP (fmap toPat ps)- toPat (Hs.PList ps) = ListP (fmap toPat ps)- toPat (Hs.PParen p) = toPat p- toPat (Hs.PRec n pfs) = let toFieldPat (Hs.PFieldPat n p) = (toName n, toPat p)- in RecP (toName n) (fmap toFieldPat pfs)- toPat (Hs.PAsPat n p) = AsP (toName n) (toPat p)- toPat (Hs.PWildCard) = WildP- toPat (Hs.PIrrPat p) = TildeP (toPat p)- toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)- toPat (Hs.PRPat rps) = error "toPat: HsRPat not supported"- toPat (Hs.PXTag _ _ _ pM p) = error "toPat: HsPXTag not supported"- toPat (Hs.PXETag _ _ _ pM) = error "toPat: HsPXETag not supported"- toPat (Hs.PXPcdata _) = error "toPat: HsPXPcdata not supported"- toPat (Hs.PXPatTag p) = error "toPat: HsPXPatTag not supported"- toPat (Hs.PBangPat p) = BangP (toPat p)----------------------------------------------------------------------------------- * ToExp HsExp--instance ToExp Hs.QOp where- toExp (Hs.QVarOp n) = VarE (toName n)- toExp (Hs.QConOp n) = ConE (toName n)--toFieldExp :: Hs.FieldUpdate -> FieldExp-toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e)-----instance ToExp Hs.Exp where-{--data HsExp- = HsVar HsQName--}--- | HsIPVar HsIPName-{-- | HsLet HsBinds HsExp- | HsDLet [HsIPBind] HsExp- | HsWith HsExp [HsIPBind]- | HsCase HsExp [HsAlt]- | HsDo [HsStmt]- -- use mfix somehow- | HsMDo [HsStmt]--}- toExp (Hs.Var n) = VarE (toName n)- toExp (Hs.Con n) = ConE (toName n)- toExp (Hs.Lit l) = LitE (toLit l)- toExp (Hs.InfixApp e o f) = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)- toExp (Hs.LeftSection e o) = InfixE (Just . toExp $ e) (toExp o) Nothing- toExp (Hs.RightSection o f) = InfixE Nothing (toExp o) (Just . toExp $ f)- toExp (Hs.App e f) = AppE (toExp e) (toExp f)- toExp (Hs.NegApp e) = AppE (VarE 'negate) (toExp e)- toExp (Hs.Lambda _ ps e) = LamE (fmap toPat ps) (toExp e)- toExp (Hs.Let bs e) = LetE (hsBindsToDecs bs) (toExp e)- -- toExp (HsWith e bs- toExp (Hs.If a b c) = CondE (toExp a) (toExp b) (toExp c)- -- toExp (HsCase e xs)- -- toExp (HsDo ss)- -- toExp (HsMDo ss)- toExp (Hs.Tuple xs) = TupE (fmap toExp xs)- toExp (Hs.List xs) = ListE (fmap toExp xs)- toExp (Hs.Paren e) = toExp e- toExp (Hs.RecConstr n xs) = RecConE (toName n) (fmap toFieldExp xs)- toExp (Hs.RecUpdate e xs) = RecUpdE (toExp e) (fmap toFieldExp xs)- toExp (Hs.EnumFrom e) = ArithSeqE $ FromR (toExp e)- toExp (Hs.EnumFromTo e f) = ArithSeqE $ FromToR (toExp e) (toExp f)- toExp (Hs.EnumFromThen e f) = ArithSeqE $ FromThenR (toExp e) (toExp f)- toExp (Hs.EnumFromThenTo e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)- toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t)- -- HsListComp HsExp [HsStmt]- -- toExp (HsListComp e ss) = CompE - -- NEED: a way to go e -> Stmt- toExp a@(Hs.ListComp e ss) = error $ errorMsg "toExp" a-{- HsVarQuote HsQName- | HsTypQuote HsQName- | HsBracketExp HsBracket- | HsSpliceExp HsSplice-data HsBracket- = HsExpBracket HsExp- | HsPatBracket HsPat- | HsTypeBracket HsType- | HsDeclBracket [HsDecl]-data HsSplice = HsIdSplice String | HsParenSplice HsExp -}- toExp (Hs.SpliceExp spl) = toExp spl- toExp (Hs.Case e alts) = CaseE (toExp e) (map toMatch alts)- toExp e = error $ errorMsg "toExp" e---instance ToExp Hs.Splice where- toExp (Hs.IdSplice s) = VarE (toName s)- toExp (Hs.ParenSplice e) = toExp e--toMatch (Hs.Alt _ p galts ds) = Match (toPat p) (toBody galts) (toDecs ds)-toBody (Hs.UnGuardedAlt e) = NormalB $ toExp e-toBody (Hs.GuardedAlts alts) = GuardedB $ map toGuard alts-toGuard (Hs.GuardedAlt _ ([Hs.Qualifier e1]) e2) = (NormalG $ toExp e1,toExp e2)---------------------------------------------------------------------------------{--class ToName a where toName :: a -> Name-class ToLit a where toLit :: a -> Lit-class ToType a where toType :: a -> Type-class ToPat a where toPat :: a -> Pat-class ToExp a where toExp :: a -> Exp-class ToDec a where toDec :: a -> Dec-class ToStmt a where toStmt :: a -> Stmt-class ToLoc a where toLoc :: a -> Loc--}--{--TODO:- []--PARTIAL:- * ToExp HsExp- * ToStmt HsStmt- * ToDec HsDecl--DONE:- * ToLit HsLiteral- * ToName {..}- * ToPat HsPat- * ToLoc SrcLoc- * ToType HsType---}---------------------------------------------------------------------------------- * ToLoc SrcLoc--instance ToLoc Hs.SrcLoc where- toLoc (Hs.SrcLoc fn l c) =- Loc fn [] [] (l,c) (-1,-1)----------------------------------------------------------------------------------- * ToType HsType--instance ToName Hs.TyVarBind where- toName (Hs.KindedVar n _) = toName n- toName (Hs.UnkindedVar n) = toName n--instance ToName TyVarBndr where- toName (PlainTV n) = n- toName (KindedTV n _) = n--toKind :: Hs.Kind -> Kind-toKind Hs.KindStar = StarK-toKind (Hs.KindFn k1 k2) = ArrowK (toKind k1) (toKind k2)-toKind (Hs.KindParen kp) = toKind kp-toKind Hs.KindBang = error "toKind: HsKindBang not supported"-toKind (Hs.KindVar _) = error "toKind: HsKindVar not supported"--toTyVar :: Hs.TyVarBind -> TyVarBndr-toTyVar (Hs.KindedVar n k) = KindedTV (toName n) (toKind k)-toTyVar (Hs.UnkindedVar n) = PlainTV (toName n)--{- |-TH does't handle- * unboxed tuples- * implicit params- * infix type constructors- * kind signatures--}-instance ToType Hs.Type where- toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t)- toType (Hs.TyFun a b) = toType a .->. toType b- toType (Hs.TyList t) = ListT `AppT` toType t- toType (Hs.TyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)- toType (Hs.TyApp a b) = AppT (toType a) (toType b)- toType (Hs.TyVar n) = VarT (toName n)- toType (Hs.TyCon qn) = ConT (toName qn)- toType (Hs.TyParen t) = toType t- -- XXX: need to wrap the name in parens!- toType (Hs.TyInfix a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b)- toType (Hs.TyKind t _) = toType t-----(.->.) :: Type -> Type -> Type-a .->. b = AppT (AppT ArrowT a) b--{- |-TH doesn't handle:- * implicit params--}--toCxt :: Hs.Context -> Cxt-toCxt = fmap toPred- where- toPred (Hs.ClassA n ts) = ClassP (toName n) (fmap toType ts)- toPred (Hs.InfixA t1 n t2) = ClassP (toName n) (fmap toType [t1, t2])- toPred (Hs.EqualP t1 t2) = EqualP (toType t1) (toType t2)- toPred a@(Hs.IParam _ _) = error $ errorMsg "toType" a--foldAppT :: Type -> [Type] -> Type-foldAppT t ts = foldl' AppT t ts----------------------------------------------------------------------------------- * ToStmt HsStmt--instance ToStmt Hs.Stmt where- toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e)- toStmt (Hs.Qualifier e) = NoBindS (toExp e)- toStmt a@(Hs.LetStmt bnds) = LetS (hsBindsToDecs bnds)------------------------------------------------------------------------------------ * ToDec HsDecl---- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind]-hsBindsToDecs :: Hs.Binds -> [Dec]-hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds-hsBindsToDecs a@(Hs.IPBinds ipbs) = error $ errorMsg "hsBindsToDecs" a--- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp---hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)-hsBangTypeToStrictType (Hs.BangedTy t) = (IsStrict, toType t)-hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)---{--data HsTyVarBind = HsKindedVar HsName HsKind | HsUnkindedVar HsName-data HsConDecl- = HsConDecl HsName [HsBangType]- | HsRecDecl HsName [([HsName], HsBangType)]--}-{--hsQualConDeclToCon :: HsQualConDecl -> Con-hsQualConDeclToCon (HsQualConDecl _ tvbs cxt condec) =- case condec of- HsConDecl n bangs ->- HsRecDecl n assocs ->--}-----instance ToDec Hs.Decl where- toDec (Hs.TypeDecl _ n ns t)- = TySynD (toName n) (fmap toTyVar ns) (toType t)--- toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns)- = case dOrN of- Hs.DataType -> DataD (toCxt cxt)- (toName n)- (fmap toTyVar ns)- (fmap qualConDeclToCon qcds)- (fmap (toName . fst) qns)- Hs.NewType -> let qcd = case qcds of- x:_ -> x- _ -> error "toDec: Newtype has no constructors!"- in NewtypeD (toCxt cxt)- (toName n)- (fmap toTyVar ns)- (qualConDeclToCon qcd)- (fmap (toName . fst) qns)---- data Hs.BangType--- = Hs.BangedTy Hs.Type--- | Hs.UnBangedTy Hs.Type--- | Hs.UnpackedTy Hs.Type--- data Hs.TyVarBind--- = Hs.KindedVar Hs.Name Hs.Kind | Hs.UnkindedVar Hs.Name--- data Hs.DataOrNew = Hs.DataType | Hs.NewType--- data Hs.QualConDecl--- = Hs.QualConDecl Hs.SrcLoc [Hs.TyVarBind] Hs.Context Hs.ConDecl--- data Hs.ConDecl--- = Hs.ConDecl Hs.Name [Hs.BangType]--- | Hs.RecDecl Hs.Name [([Hs.Name], Hs.BangType)]---- data Con--- = NormalC Name [StrictType]--- | RecC Name [VarStrictType]--- | InfixC StrictType Name StrictType--- | ForallC [Name] Cxt Con--- type StrictType = (Strict, Type)--- type VarStrictType = (Name, Strict, Type)--- toDec a@(Hs.GDataDecl _ dOrN cxt n ns kM gadtDecs _) = error $ errorMsg "toDec" a- toDec a@(Hs.TypeFamDecl _ n ns kM) = error $ errorMsg "toDec" a- toDec a@(Hs.DataFamDecl _ cxt n ns kM) = error $ errorMsg "toDec" a- toDec a@(Hs.TypeInsDecl _ ta tb) = error $ errorMsg "toDec" a- toDec a@(Hs.DataInsDecl _ dOrN t qcds qns) = error $ errorMsg "toDec" a- toDec a@(Hs.GDataInsDecl _ dOrN t kM gadtDecs _) = error $ errorMsg "toDec" a--- data HsOp = HsVarOp HsName | HsConOp HsName- toDec a@(Hs.InfixDecl _ asst i ops) = error $ errorMsg "toDec" a- toDec a@(Hs.ClassDecl _ cxt n ns funDeps cDecs) = error $ errorMsg "toDec" a- toDec a@(Hs.InstDecl _ cxt qn ts instDecs) = error $ errorMsg "toDec" a- toDec a@(Hs.DerivDecl _ cxt qn ts) = error $ errorMsg "toDec" a - toDec a@(Hs.DefaultDecl _ ts) = error $ errorMsg "toDec" a- toDec a@(Hs.SpliceDecl _ s) = error $ errorMsg "toDec" a- -- This type-signature conversion is just wrong. - -- Type variables need to be dealt with. /Jonas- toDec a@(Hs.TypeSig _ ns t)- -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!- = let xs = fmap (flip SigD (toType t) . toName) ns- in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"- toDec (Hs.InlineSig _ b act id) = PragmaD $ - InlineP (toName id) (InlineSpec True False Nothing)--{- data HsDecl = ... | HsFunBind [HsMatch] | ...-data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds-data Dec = FunD Name [Clause] | ...-data Clause = Clause [Pat] Body [Dec] -}- toDec a@(Hs.FunBind mtchs) = hsMatchesToFunD mtchs-{- ghci> parseExp "let x = 2 in x"-LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x)-ghci> unQ[| let x = 2 in x |]-LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -}- toDec (Hs.PatBind _ p tM rhs bnds) = ValD ((maybe id- (flip SigP . toType)- tM) (toPat p))- (hsRhsToBody rhs)- (hsBindsToDecs bnds)- toDec a@(Hs.ForImp _ cconv safe str n t) = error $ errorMsg "toDec" a- toDec a@(Hs.ForExp _ cconv str n t) = error $ errorMsg "toDec" a-- toDec x = error $ "toDec: Untranslatable declaration:" ++ (show x)----- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ...--- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp-----------qualConDeclToCon :: Hs.QualConDecl -> Con-qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl-qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTyVar ns)- (toCxt cxt)- (conDeclToCon cdecl)--conDeclToCon :: Hs.ConDecl -> Con-conDeclToCon (Hs.ConDecl n tys)- = NormalC (toName n) (fmap bangToStrictType tys)-conDeclToCon (Hs.RecDecl n lbls)- = RecC (toName n) (concatMap (uncurry bangToVarStrictTypes) lbls)----bangToVarStrictTypes :: [Hs.Name] -> Hs.BangType -> [VarStrictType]-bangToVarStrictTypes ns t = let (a,b) = bangToStrictType t- in fmap (\n->(toName n,a,b)) ns--bangToStrictType :: Hs.BangType -> StrictType-bangToStrictType (Hs.BangedTy t) = (IsStrict, toType t)-bangToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)-bangToStrictType (Hs.UnpackedTy t) = (IsStrict, toType t)---hsMatchesToFunD :: [Hs.Match] -> Dec-hsMatchesToFunD [] = FunD (mkName []) [] -- errorish-hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)---hsMatchToClause :: Hs.Match -> Clause-hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause- (fmap toPat ps)- (hsRhsToBody rhs)- (hsBindsToDecs bnds)------ data HsRhs = HsUnGuardedRhs HsExp | HsGuardedRhs [HsGuardedRhs]--- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp--- data Body = GuardedB [(Guard, Exp)] | NormalB Exp--- data Guard = NormalG Exp | PatG [Stmt]-hsRhsToBody :: Hs.Rhs -> Body-hsRhsToBody (Hs.UnGuardedRhs e) = NormalB (toExp e)-hsRhsToBody (Hs.GuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a- in GuardedB . concat- . fmap (fromGuardedB . hsGuardedRhsToBody)- $ hsgrhs----hsGuardedRhsToBody :: Hs.GuardedRhs -> Body-hsGuardedRhsToBody (Hs.GuardedRhs _ [] e) = NormalB (toExp e)-hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]-hsGuardedRhsToBody (Hs.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss- (pgs,ngs) = unzip [(p,n)- | (PatG p) <- ss'- , n@(NormalG _) <- ss']- e' = toExp e- patg = PatG (concat pgs)- in GuardedB $ (patg,e') : zip ngs (repeat e')----hsStmtToGuard :: Hs.Stmt -> Guard-hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]-hsStmtToGuard (Hs.Qualifier e) = NormalG (toExp e)-hsStmtToGuard a@(Hs.LetStmt _) = error $ errorMsg "hsStmtToGuardExp" a------------------------------------------------------------------------------------ * ToDecs HsDecl HsBinds--instance ToDecs Hs.Decl where--- toDecs a@(Hs.InfixDecl _ asst i ops) = [] -- HACK--- toDecs (Hs.InlineSig _ _ _ _) = [] -- HACK- toDecs a@(Hs.TypeSig _ ns t)- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns- in xs--- toDecs a = [toDec a]--collectVars e = case e of- VarT n -> [PlainTV n]- AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2- ForallT ns _ t -> collectVars t \\ ns- _ -> []--fixForall t = case vs of- [] -> t- _ -> ForallT vs [] t- where vs = collectVars t--instance ToDecs a => ToDecs [a] where- toDecs a = concatMap toDecs a--instance ToDecs Hs.Binds where- toDecs (Hs.BDecls ds) = toDecs ds--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++{- |+ Module : Language.Haskell.Meta.Syntax.Translate+ Copyright : (c) Matt Morrow 2008+ License : BSD3+ Maintainer : Matt Morrow <mjm2002@gmail.com>+ Stability : experimental+ Portability : portable (template-haskell)+-}++module Language.Haskell.Meta.Syntax.Translate (+ module Language.Haskell.Meta.Syntax.Translate+ , TyVarBndr_+) where++import qualified Data.Char as Char+import qualified Data.List as List+import qualified Language.Haskell.Exts.SrcLoc as Exts.SrcLoc+import qualified Language.Haskell.Exts.Syntax as Exts+import Language.Haskell.Meta.THCompat (TyVarBndr_)+import qualified Language.Haskell.Meta.THCompat as Compat+import qualified Language.Haskell.TH.Lib as TH+import qualified Language.Haskell.TH.Syntax as TH++-----------------------------------------------------------------------------++class ToName a where toName :: a -> TH.Name+class ToNames a where toNames :: a -> [TH.Name]+class ToLit a where toLit :: a -> TH.Lit+class ToType a where toType :: a -> TH.Type+class ToPat a where toPat :: a -> TH.Pat+class ToExp a where toExp :: a -> TH.Exp+class ToDecs a where toDecs :: a -> [TH.Dec]+class ToDec a where toDec :: a -> TH.Dec+class ToStmt a where toStmt :: a -> TH.Stmt+class ToLoc a where toLoc :: a -> TH.Loc+class ToCxt a where toCxt :: a -> TH.Cxt+class ToPred a where toPred :: a -> TH.Pred+class ToTyVars a where toTyVars :: a -> [TyVarBndr_ ()]+class ToMaybeKind a where toMaybeKind :: a -> Maybe TH.Kind+class ToInjectivityAnn a where toInjectivityAnn :: a -> TH.InjectivityAnn++type DerivClause = TH.DerivClause++class ToDerivClauses a where toDerivClauses :: a -> [DerivClause]++-- for error messages+moduleName :: String+moduleName = "Language.Haskell.Meta.Syntax.Translate"++-- When to use each of these isn't always clear: prefer 'todo' if unsure.+noTH :: (Functor f, Show (f ())) => String -> f e -> a+noTH fun thing = error . concat $ [moduleName, ".", fun,+ ": template-haskell has no representation for: ", show (fmap (const ()) thing)]++noTHyet :: (Functor f, Show (f ())) => String -> String -> f e -> a+noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun,+ ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")",+ " has no representation for: ", show (fmap (const ()) thing)]++todo :: (Functor f, Show (f ())) => String -> f e -> a+todo fun thing = error . concat $ [moduleName, ".", fun,+ ": not implemented: ", show (fmap (const ()) thing)]++nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a+nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun,+ ": nonsensical: ", inparticular, ": ", show (fmap (const ()) thing)]++#if MIN_VERSION_template_haskell(2,16,0)+toTupEl :: ToExp a => a -> Maybe TH.Exp+toTupEl = Just . toExp+#else+toTupEl :: ToExp a => a -> TH.Exp+toTupEl = toExp+#endif++-----------------------------------------------------------------------------+++instance ToExp TH.Lit where+ toExp = TH.LitE+instance (ToExp a) => ToExp [a] where+ toExp = TH.ListE . fmap toExp+instance (ToExp a, ToExp b) => ToExp (a,b) where+ toExp (a,b) = TH.TupE [toTupEl a, toTupEl b]+instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where+ toExp (a,b,c) = TH.TupE [toTupEl a, toTupEl b, toTupEl c]+instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where+ toExp (a,b,c,d) = TH.TupE [toTupEl a, toTupEl b, toTupEl c, toTupEl d]+++instance ToPat TH.Lit where+ toPat = TH.LitP+instance (ToPat a) => ToPat [a] where+ toPat = TH.ListP . fmap toPat+instance (ToPat a, ToPat b) => ToPat (a,b) where+ toPat (a,b) = TH.TupP [toPat a, toPat b]+instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where+ toPat (a,b,c) = TH.TupP [toPat a, toPat b, toPat c]+instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where+ toPat (a,b,c,d) = TH.TupP [toPat a, toPat b, toPat c, toPat d]+++instance ToLit Char where+ toLit = TH.CharL+instance ToLit String where+ toLit = TH.StringL+instance ToLit Integer where+ toLit = TH.IntegerL+instance ToLit Int where+ toLit = TH.IntegerL . toInteger+instance ToLit Float where+ toLit = TH.RationalL . toRational+instance ToLit Double where+ toLit = TH.RationalL . toRational+++-----------------------------------------------------------------------------+++-- * ToName {String,HsName,Module,HsSpecialCon,HsQName}+++instance ToName String where+ toName = TH.mkName++instance ToName (Exts.Name l) where+ toName (Exts.Ident _ s) = toName s+ toName (Exts.Symbol _ s) = toName s++instance ToName (Exts.SpecialCon l) where+ toName (Exts.UnitCon _) = TH.mkName "()" -- TODO LumiGuide: '()+ toName (Exts.ListCon _) = ''[] -- Parser only uses this in types -- TODO LumiGuide: '[]+ toName (Exts.FunCon _) = ''(->)+ toName (Exts.TupleCon _ _ n) =+ TH.mkName $ concat ["(",replicate (n-1) ',',")"]+ -- TODO LumiGuide:+ -- .+ -- .| n<2 = '()+ -- .| otherwise =+ -- . let x = maybe [] (++".") (nameModule '(,))+ -- . in TH.mkName . concat $ x : ["(",replicate (n-1) ',',")"]+ toName (Exts.Cons _) = '(:)+ toName h = todo "toName not implemented" h+ -- TODO+ -- toName (Exts.UnboxedSingleCon _) = ''+ -- toName (Exts.ExprHole _) = ''_+++instance ToName (Exts.QName l) where+-- TODO: why is this commented out?+-- toName (Exts.Qual (Exts.Module []) n) = toName n+ toName (Exts.Qual _ (Exts.ModuleName _ []) n) = toName n+ toName (Exts.Qual _ (Exts.ModuleName _ m) n) =+ let m' = show . toName $ m+ n' = show . toName $ n+ in toName . concat $ [m',".",n']+ toName (Exts.UnQual _ n) = toName n+ toName (Exts.Special _ s) = toName s++#if MIN_VERSION_haskell_src_exts(1,20,1)+instance ToName (Exts.MaybePromotedName l) where+ toName (Exts.PromotedName _ qn) = toName qn+ toName (Exts.UnpromotedName _ qn) = toName qn+#endif++instance ToName (Exts.Op l) where+ toName (Exts.VarOp _ n) = toName n+ toName (Exts.ConOp _ n) = toName n+++-----------------------------------------------------------------------------++-- * ToLit HsLiteral+++instance ToLit (Exts.Literal l) where+ toLit (Exts.Char _ a _) = TH.CharL a+ toLit (Exts.String _ a _) = TH.StringL a+ toLit (Exts.Int _ a _) = TH.IntegerL a+ toLit (Exts.Frac _ a _) = TH.RationalL a+ toLit l@Exts.PrimChar{} = noTH "toLit" l+ toLit (Exts.PrimString _ a _) = TH.StringPrimL (map toWord8 a)+ where+ toWord8 = fromIntegral . Char.ord+ toLit (Exts.PrimInt _ a _) = TH.IntPrimL a+ toLit (Exts.PrimFloat _ a _) = TH.FloatPrimL a+ toLit (Exts.PrimDouble _ a _) = TH.DoublePrimL a+ toLit (Exts.PrimWord _ a _) = TH.WordPrimL a+++-----------------------------------------------------------------------------++-- * ToPat HsPat++instance ToPat (Exts.Pat l) where+ toPat (Exts.PVar _ n)+ = TH.VarP (toName n)+ toPat (Exts.PLit _ (Exts.Signless _) l)+ = TH.LitP (toLit l)+ toPat (Exts.PLit _ (Exts.Negative _) l) = TH.LitP $ case toLit l of+ TH.IntegerL z -> TH.IntegerL (negate z)+ TH.RationalL q -> TH.RationalL (negate q)+ TH.IntPrimL z' -> TH.IntPrimL (negate z')+ TH.FloatPrimL r' -> TH.FloatPrimL (negate r')+ TH.DoublePrimL r'' -> TH.DoublePrimL (negate r'')+ _ -> nonsense "toPat" "negating wrong kind of literal" l+ toPat (Exts.PInfixApp _ p n q) = TH.UInfixP (toPat p) (toName n) (toPat q)+ toPat (Exts.PApp _ n ps) = Compat.conP (toName n) (fmap toPat ps)+ toPat (Exts.PTuple _ Exts.Boxed ps) = TH.TupP (fmap toPat ps)+ toPat (Exts.PTuple _ Exts.Unboxed ps) = TH.UnboxedTupP (fmap toPat ps)+ toPat (Exts.PList _ ps) = TH.ListP (fmap toPat ps)+ toPat (Exts.PParen _ p) = TH.ParensP (toPat p)+ -- TODO: move toFieldPat to top level defn+ toPat (Exts.PRec _ n pfs) = let toFieldPat (Exts.PFieldPat _ n' p) = (toName n', toPat p)+ toFieldPat h = todo "toFieldPat" h+ in TH.RecP (toName n) (fmap toFieldPat pfs)+ toPat (Exts.PAsPat _ n p) = TH.AsP (toName n) (toPat p)+ toPat (Exts.PWildCard _) = TH.WildP+ toPat (Exts.PIrrPat _ p) = TH.TildeP (toPat p)+ toPat (Exts.PatTypeSig _ p t) = TH.SigP (toPat p) (toType t)+ toPat (Exts.PViewPat _ e p) = TH.ViewP (toExp e) (toPat p)+ -- regular pattern+ toPat p@Exts.PRPat{} = noTH "toPat" p+ -- XML stuff+ toPat p@Exts.PXTag{} = noTH "toPat" p+ toPat p@Exts.PXETag{} = noTH "toPat" p+ toPat p@Exts.PXPcdata{} = noTH "toPat" p+ toPat p@Exts.PXPatTag{} = noTH "toPat" p+ toPat (Exts.PBangPat _ p) = TH.BangP (toPat p)+ toPat p = todo "toPat" p+ -- TODO+ -- (Exts.PNPlusK _ _ _)+ -- (Exts.PUnboxedSum _ _ _ _)+ -- (Exts.PXRPats _ _)+ -- (Exts.PSplice _ _)+ -- ...++-----------------------------------------------------------------------------++-- * ToExp HsExp++instance ToExp (Exts.QOp l) where+ toExp (Exts.QVarOp _ n) = TH.VarE (toName n)+ toExp (Exts.QConOp _ n) = TH.ConE (toName n)++toFieldExp :: Exts.FieldUpdate l -> TH.FieldExp+toFieldExp (Exts.FieldUpdate _ n e) = (toName n, toExp e)+toFieldExp h = todo "toFieldExp" h+++++instance ToExp (Exts.Exp l) where+ toExp (Exts.Var _ n) = TH.VarE (toName n)+ toExp e@Exts.IPVar{} = noTH "toExp" e+ toExp (Exts.Con _ n) = TH.ConE (toName n)+ toExp (Exts.Lit _ l) = TH.LitE (toLit l)+#if MIN_VERSION_template_haskell(2,13,0)+ toExp (Exts.OverloadedLabel _ s) = TH.LabelE s+#endif+ toExp (Exts.InfixApp _ e o f) = TH.UInfixE (toExp e) (toExp o) (toExp f)+ toExp (Exts.App _ e (Exts.TypeApp _ t)) = TH.AppTypeE (toExp e) (toType t)+ toExp (Exts.App _ e f) = TH.AppE (toExp e) (toExp f)+ toExp (Exts.NegApp _ e) = TH.AppE (TH.VarE 'negate) (toExp e)+ toExp (Exts.Lambda _ ps e) = TH.LamE (fmap toPat ps) (toExp e)+ toExp (Exts.Let _ bs e) = TH.LetE (toDecs bs) (toExp e)+ toExp (Exts.If _ a b c) = TH.CondE (toExp a) (toExp b) (toExp c)+ toExp (Exts.MultiIf _ ifs) = TH.MultiIfE (map toGuard ifs)+ toExp (Exts.Case _ e alts) = TH.CaseE (toExp e) (map toMatch alts)+#if MIN_VERSION_template_haskell(2,17,0)+ toExp (Exts.Do _ ss) = TH.DoE Nothing (map toStmt ss)+#else+ toExp (Exts.Do _ ss) = TH.DoE (map toStmt ss)+#endif+ toExp e@Exts.MDo{} = noTH "toExp" e+ toExp (Exts.Tuple _ Exts.Boxed xs) = TH.TupE (fmap toTupEl xs)+ toExp (Exts.Tuple _ Exts.Unboxed xs) = TH.UnboxedTupE (fmap toTupEl xs)+ toExp e@Exts.TupleSection{} = noTH "toExp" e+ toExp (Exts.List _ xs) = TH.ListE (fmap toExp xs)+ toExp (Exts.Paren _ e) = TH.ParensE (toExp e)+ toExp (Exts.LeftSection _ e o) = TH.InfixE (Just . toExp $ e) (toExp o) Nothing+ toExp (Exts.RightSection _ o f) = TH.InfixE Nothing (toExp o) (Just . toExp $ f)+ toExp (Exts.RecConstr _ n xs) = TH.RecConE (toName n) (fmap toFieldExp xs)+ toExp (Exts.RecUpdate _ e xs) = TH.RecUpdE (toExp e) (fmap toFieldExp xs)+ toExp (Exts.EnumFrom _ e) = TH.ArithSeqE $ TH.FromR (toExp e)+ toExp (Exts.EnumFromTo _ e f) = TH.ArithSeqE $ TH.FromToR (toExp e) (toExp f)+ toExp (Exts.EnumFromThen _ e f) = TH.ArithSeqE $ TH.FromThenR (toExp e) (toExp f)+ toExp (Exts.EnumFromThenTo _ e f g) = TH.ArithSeqE $ TH.FromThenToR (toExp e) (toExp f) (toExp g)+ toExp (Exts.ListComp _ e ss) = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)]+ where+ convert (Exts.QualStmt _ st) = toStmt st+ convert s = noTH "toExp ListComp" s+ toExp (Exts.ExpTypeSig _ e t) = TH.SigE (toExp e) (toType t)+ toExp e = todo "toExp" e+++toMatch :: Exts.Alt l -> TH.Match+toMatch (Exts.Alt _ p rhs ds) = TH.Match (toPat p) (toBody rhs) (toDecs ds)++toBody :: Exts.Rhs l -> TH.Body+toBody (Exts.UnGuardedRhs _ e) = TH.NormalB $ toExp e+toBody (Exts.GuardedRhss _ rhss) = TH.GuardedB $ map toGuard rhss++toGuard :: Exts.GuardedRhs l -> (TH.Guard, TH.Exp)+toGuard (Exts.GuardedRhs _ stmts e) = (g, toExp e)+ where+ g = case map toStmt stmts of+ [TH.NoBindS x] -> TH.NormalG x+ xs -> TH.PatG xs++instance ToDecs a => ToDecs (Maybe a) where+ toDecs Nothing = []+ toDecs (Just a) = toDecs a++instance ToDecs (Exts.Binds l) where+ toDecs (Exts.BDecls _ ds) = toDecs ds+ toDecs a@(Exts.IPBinds {}) = noTH "ToDecs Exts.Binds" a++instance ToDecs (Exts.ClassDecl l) where+ toDecs (Exts.ClsDecl _ d) = toDecs d+ toDecs x = todo "classDecl" x++-----------------------------------------------------------------------------++-- * ToLoc SrcLoc++instance ToLoc Exts.SrcLoc.SrcLoc where+ toLoc (Exts.SrcLoc.SrcLoc fn l c) =+ TH.Loc fn [] [] (l,c) (-1,-1)++-----------------------------------------------------------------------------++-- * ToType HsType++instance ToName (Exts.TyVarBind l) where+ toName (Exts.KindedVar _ n _) = toName n+ toName (Exts.UnkindedVar _ n) = toName n++instance ToName TH.Name where+ toName = id++instance ToName (Compat.TyVarBndr_ flag) where+#if MIN_VERSION_template_haskell(2,17,0)+ toName (TH.PlainTV n _) = n+ toName (TH.KindedTV n _ _) = n+#else+ toName (TH.PlainTV n) = n+ toName (TH.KindedTV n _) = n+#endif++#if !MIN_VERSION_haskell_src_exts(1,21,0)+instance ToType (Exts.Kind l) where+ toType (Exts.KindStar _) = TH.StarT+ toType (Exts.KindFn _ k1 k2) = toType k1 .->. toType k2+ toType (Exts.KindParen _ kp) = toType kp+ toType (Exts.KindVar _ n) = TH.VarT (toName n)+ -- TODO LumiGuide:+ -- toType (Hs.KindVar _ n)+ -- | isCon (nameBase th_n) = ConT th_n+ -- | otherwise = VarT th_n+ -- where+ -- th_n = toName n+ --+ -- isCon :: String -> Bool+ -- isCon (c:_) = isUpper c || c == ':'+ -- isCon _ = nonsense "toType" "empty kind variable name" n+ toType (Exts.KindApp _ k1 k2) = toType k1 `TH.AppT` toType k2+ toType (Exts.KindTuple _ ks) = foldr (\k pt -> pt `TH.AppT` toType k) (TH.TupleT $ length ks) ks+ toType (Exts.KindList _ k) = TH.ListT `TH.AppT` toType k+#endif++toKind :: Exts.Kind l -> TH.Kind+toKind = toType++toTyVar :: Exts.TyVarBind l -> TyVarBndr_ ()+#if MIN_VERSION_template_haskell(2,17,0)+toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) () (toKind k)+toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n) ()+#else+toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) (toKind k)+toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n)+#endif++#if MIN_VERSION_template_haskell(2,17,0)+toTyVarSpec :: TyVarBndr_ () -> TH.TyVarBndrSpec+toTyVarSpec (TH.KindedTV n () k) = TH.KindedTV n TH.SpecifiedSpec k+toTyVarSpec (TH.PlainTV n ()) = TH.PlainTV n TH.SpecifiedSpec+#else+toTyVarSpec :: TyVarBndr_ flag -> TyVarBndr_ flag+toTyVarSpec = id+#endif++-- TODO (int-index): Use MIN_VERSION_template_haskell(2,21,0)+#if __GLASGOW_HASKELL__ >= 907+toTyVarsVis :: ToTyVars a => a -> [TH.TyVarBndrVis]+toTyVarsVis = map toTyVarVis . toTyVars+ where+ toTyVarVis (TH.KindedTV n () k) = TH.KindedTV n TH.BndrReq k+ toTyVarVis (TH.PlainTV n ()) = TH.PlainTV n TH.BndrReq+#else+toTyVarsVis :: ToTyVars a => a -> [TyVarBndr_ ()]+toTyVarsVis = toTyVars+#endif++instance ToType (Exts.Type l) where+ toType (Exts.TyForall _ tvbM cxt t) = TH.ForallT (maybe [] (fmap (toTyVarSpec . toTyVar)) tvbM) (toCxt cxt) (toType t)+ toType (Exts.TyFun _ a b) = toType a .->. toType b+ toType (Exts.TyList _ t) = TH.ListT `TH.AppT` toType t+ toType (Exts.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts)+ where+ tuple = case b of+ Exts.Boxed -> TH.TupleT+ Exts.Unboxed -> TH.UnboxedTupleT+ toType (Exts.TyApp _ a b) = TH.AppT (toType a) (toType b)+ toType (Exts.TyVar _ n) = TH.VarT (toName n)+ toType (Exts.TyCon _ qn) = TH.ConT (toName qn)+ toType (Exts.TyParen _ t) = toType t+ -- XXX: need to wrap the name in parens!+#if MIN_VERSION_haskell_src_exts(1,20,0)+ -- TODO: why does this branch exist?+ -- Why fail toType if this is a promoted name?+ toType (Exts.TyInfix _ a (Exts.UnpromotedName _ o) b) =+ TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b)+#else+ toType (Exts.TyInfix _ a o b) =+ TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b)+#endif+ toType (Exts.TyKind _ t k) = TH.SigT (toType t) (toKind k)+ toType (Exts.TyPromoted _ p) = case p of+ Exts.PromotedInteger _ i _ -> TH.LitT $ TH.NumTyLit i+ Exts.PromotedString _ _ s -> TH.LitT $ TH.StrTyLit s+ Exts.PromotedCon _ _q n -> TH.PromotedT $ toName n+ Exts.PromotedList _ _q ts -> foldr (\t pl -> TH.PromotedConsT `TH.AppT` toType t `TH.AppT` pl) TH.PromotedNilT ts+ Exts.PromotedTuple _ ts -> foldl (\pt t -> pt `TH.AppT` toType t) (TH.PromotedTupleT $ length ts) ts+ Exts.PromotedUnit _ -> TH.PromotedT ''()+ toType (Exts.TyEquals _ t1 t2) = TH.EqualityT `TH.AppT` toType t1 `TH.AppT` toType t2+ toType t@Exts.TySplice{} = noTH "toType" t+ toType t@Exts.TyBang{} =+ nonsense "toType" "type cannot have strictness annotations in this context" t+ toType t@Exts.TyWildCard{} = noTH "toType" t+ toType t = todo "toType" t+ -- TODO+ -- toType (Exts.TyUnboxedSum _ _)+ -- toType (Exts.TyParArray _ _)+ -- toType (Exts.TyInfix _ _ (Exts.PromotedName _ _) _)++toStrictType :: Exts.Type l -> TH.StrictType+toStrictType (Exts.TyBang _ s u t) = (TH.Bang (toUnpack u) (toStrict s), toType t)+ where+ toStrict (Exts.LazyTy _) = TH.SourceLazy+ toStrict (Exts.BangedTy _) = TH.SourceStrict+ toStrict (Exts.NoStrictAnnot _) = TH.NoSourceStrictness+ toUnpack (Exts.Unpack _) = TH.SourceUnpack+ toUnpack (Exts.NoUnpack _) = TH.SourceNoUnpack+ toUnpack (Exts.NoUnpackPragma _) = TH.NoSourceUnpackedness+toStrictType x = (TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness, toType x)++(.->.) :: TH.Type -> TH.Type -> TH.Type+a .->. b = TH.AppT (TH.AppT TH.ArrowT a) b++instance ToPred (Exts.Asst l) where+#if MIN_VERSION_haskell_src_exts(1,22,0)+ toPred (Exts.TypeA _ t) = toType t+#else+ toPred (Exts.ClassA _ n ts) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType ts)+ toPred (Exts.InfixA _ t1 n t2) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType [t1,t2])+ toPred (Exts.EqualP _ t1 t2) = List.foldl' TH.AppT TH.EqualityT (fmap toType [t1,t2])+ toPred a@Exts.AppA{} = todo "toPred" a+ toPred a@Exts.WildCardA{} = todo "toPred" a+#endif+ toPred (Exts.ParenA _ asst) = toPred asst+ toPred a@Exts.IParam{} = noTH "toPred" a+ -- Pattern match is redundant.+ -- TODO: Is there a way to turn off this warn for catch-alls?+ -- would make the code more future-compat+ -- toPred p = todo "toPred" p++instance ToDerivClauses (Exts.Deriving l) where+#if MIN_VERSION_haskell_src_exts(1,20,0)+ toDerivClauses (Exts.Deriving _ strat irules) = [TH.DerivClause (fmap toDerivStrategy strat) (map toType irules)]+#else+ toDerivClauses (Exts.Deriving _ irules) = [TH.DerivClause Nothing (map toType irules)]+#endif++instance ToDerivClauses a => ToDerivClauses (Maybe a) where+ toDerivClauses Nothing = []+ toDerivClauses (Just a) = toDerivClauses a++instance ToDerivClauses a => ToDerivClauses [a] where+ toDerivClauses = concatMap toDerivClauses+++toDerivStrategy :: (Exts.DerivStrategy l) -> TH.DerivStrategy+toDerivStrategy (Exts.DerivStock _) = TH.StockStrategy+toDerivStrategy (Exts.DerivAnyclass _) = TH.AnyclassStrategy+toDerivStrategy (Exts.DerivNewtype _) = TH.NewtypeStrategy+#if MIN_VERSION_haskell_src_exts(1,21,0) && MIN_VERSION_template_haskell(2,14,0)+toDerivStrategy (Exts.DerivVia _ t) = TH.ViaStrategy (toType t)+#else+toDerivStrategy d@Exts.DerivVia{} = noTHyet "toDerivStrategy" "2.14" d+#endif+++-- TODO LumiGuide+-- instance ToCxt (Hs.Deriving l) where+-- #if MIN_VERSION_haskell_src_exts(1,20,1)+-- toCxt (Hs.Deriving _ _ rule) = toCxt rule+-- #else+-- toCxt (Hs.Deriving _ rule) = toCxt rule+-- #endif++-- instance ToCxt [Hs.InstRule l] where+-- toCxt = concatMap toCxt++-- instance ToCxt a => ToCxt (Maybe a) where+-- toCxt Nothing = []+-- toCxt (Just a) = toCxt a+++foldAppT :: TH.Type -> [TH.Type] -> TH.Type+foldAppT t ts = List.foldl' TH.AppT t ts++-----------------------------------------------------------------------------++-- * ToStmt HsStmt++instance ToStmt (Exts.Stmt l) where+ toStmt (Exts.Generator _ p e) = TH.BindS (toPat p) (toExp e)+ toStmt (Exts.Qualifier _ e) = TH.NoBindS (toExp e)+ toStmt _a@(Exts.LetStmt _ bnds) = TH.LetS (toDecs bnds)+ toStmt s@Exts.RecStmt{} = noTH "toStmt" s+++-----------------------------------------------------------------------------++-- * ToDec HsDecl++instance ToDec (Exts.Decl l) where+ toDec (Exts.TypeDecl _ h t)+ = TH.TySynD (toName h) (toTyVarsVis h) (toType t)++ toDec a@(Exts.DataDecl _ dOrN cxt h qcds qns)+ = case dOrN of+ Exts.DataType _ -> TH.DataD (toCxt cxt)+ (toName h)+ (toTyVarsVis h)+ Nothing+ (fmap qualConDeclToCon qcds)+ (toDerivClauses qns)+ Exts.NewType _ -> let qcd = case qcds of+ [x] -> x+ _ -> nonsense "toDec" ("newtype with " +++ "wrong number of constructors") a+ in TH.NewtypeD (toCxt cxt)+ (toName h)+ (toTyVarsVis h)+ Nothing+ (qualConDeclToCon qcd)+ (toDerivClauses qns)++ -- This type-signature conversion is just wrong.+ -- Type variables need to be dealt with. /Jonas+ toDec _a@(Exts.TypeSig _ ns t)+ -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!+ = let xs = fmap (flip TH.SigD (toType t) . toName) ns+ in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"++ toDec (Exts.InlineConlikeSig _ act qn) = TH.PragmaD $+ TH.InlineP (toName qn) TH.Inline TH.ConLike (transAct act)+ toDec (Exts.InlineSig _ b act qn) = TH.PragmaD $+ TH.InlineP (toName qn) inline TH.FunLike (transAct act)+ where+ inline | b = TH.Inline | otherwise = TH.NoInline++ toDec (Exts.TypeFamDecl _ h sig inj)+ = TH.OpenTypeFamilyD $ TH.TypeFamilyHead (toName h)+ (toTyVarsVis h)+ (maybe TH.NoSig TH.KindSig . toMaybeKind $ sig)+ (fmap toInjectivityAnn inj)+ toDec (Exts.DataFamDecl _ _ h sig)+ = TH.DataFamilyD (toName h) (toTyVarsVis h) (toMaybeKind sig)++ toDec _a@(Exts.FunBind _ mtchs) = hsMatchesToFunD mtchs+ toDec (Exts.PatBind _ p rhs bnds) = TH.ValD (toPat p)+ (hsRhsToBody rhs)+ (toDecs bnds)++ toDec i@(Exts.InstDecl _ (Just overlap) _ _) =+ noTH "toDec" (fmap (const ()) overlap, i)++ -- the 'vars' bit seems to be for: instance forall a. C (T a) where ...+ -- TH's own parser seems to flat-out ignore them, and honestly I can't see+ -- that it's obviously wrong to do so.+ toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD+ Nothing+ (toCxt irule)+ (toType irule)+ (toDecs ids)++ toDec (Exts.ClassDecl _ cxt h fds decls) = TH.ClassD+ (toCxt cxt)+ (toName h)+ (toTyVarsVis h)+ (fmap toFunDep fds)+ (toDecs decls)+ where+ toFunDep (Exts.FunDep _ ls rs) = TH.FunDep (fmap toName ls) (fmap toName rs)++ toDec (Exts.AnnPragma _ ann) = TH.PragmaD (TH.AnnP (target ann) (expann ann))+ where+ target (Exts.Ann _ n _) = TH.ValueAnnotation (toName n)+ target (Exts.TypeAnn _ n _) = TH.TypeAnnotation (toName n)+ target (Exts.ModuleAnn _ _) = TH.ModuleAnnotation+ expann (Exts.Ann _ _ e) = toExp e+ expann (Exts.TypeAnn _ _ e) = toExp e+ expann (Exts.ModuleAnn _ e) = toExp e++ toDec x = todo "toDec" x++instance ToMaybeKind (Exts.ResultSig l) where+ toMaybeKind (Exts.KindSig _ k) = Just $ toKind k+ toMaybeKind (Exts.TyVarSig _ _) = Nothing++instance ToMaybeKind a => ToMaybeKind (Maybe a) where+ toMaybeKind Nothing = Nothing+ toMaybeKind (Just a) = toMaybeKind a++instance ToInjectivityAnn (Exts.InjectivityInfo l) where+ toInjectivityAnn (Exts.InjectivityInfo _ n ns) = TH.InjectivityAnn (toName n) (fmap toName ns)++transAct :: Maybe (Exts.Activation l) -> TH.Phases+transAct Nothing = TH.AllPhases+transAct (Just (Exts.ActiveFrom _ n)) = TH.FromPhase n+transAct (Just (Exts.ActiveUntil _ n)) = TH.BeforePhase n++instance ToName (Exts.DeclHead l) where+ toName (Exts.DHead _ n) = toName n+ toName (Exts.DHInfix _ _ n) = toName n+ toName (Exts.DHParen _ h) = toName h+ toName (Exts.DHApp _ h _) = toName h++instance ToTyVars (Exts.DeclHead l) where+ toTyVars (Exts.DHead _ _) = []+ toTyVars (Exts.DHParen _ h) = toTyVars h+ toTyVars (Exts.DHInfix _ tvb _) = [toTyVar tvb]+ toTyVars (Exts.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb]++instance ToNames a => ToNames (Maybe a) where+ toNames Nothing = []+ toNames (Just a) = toNames a++instance ToNames (Exts.Deriving l) where+#if MIN_VERSION_haskell_src_exts(1,20,0)+ toNames (Exts.Deriving _ _ irules) = concatMap toNames irules+#else+ toNames (Exts.Deriving _ irules) = concatMap toNames irules+#endif++instance ToNames (Exts.InstRule l) where+ toNames (Exts.IParen _ irule) = toNames irule+ toNames (Exts.IRule _ _mtvbs _mcxt mihd) = toNames mihd+instance ToNames (Exts.InstHead l) where+ toNames (Exts.IHCon _ n) = [toName n]+ toNames (Exts.IHInfix _ _ n) = [toName n]+ toNames (Exts.IHParen _ h) = toNames h+ toNames (Exts.IHApp _ h _) = toNames h++instance ToCxt (Exts.InstRule l) where+ toCxt (Exts.IRule _ _ cxt _) = toCxt cxt+ toCxt (Exts.IParen _ irule) = toCxt irule++instance ToCxt (Exts.Context l) where+ toCxt x = case x of+ Exts.CxEmpty _ -> []+ Exts.CxSingle _ x' -> [toPred x']+ Exts.CxTuple _ xs -> fmap toPred xs++instance ToCxt a => ToCxt (Maybe a) where+ toCxt Nothing = []+ toCxt (Just a) = toCxt a++instance ToType (Exts.InstRule l) where+ toType (Exts.IRule _ _ _ h) = toType h+ toType (Exts.IParen _ irule) = toType irule++instance ToType (Exts.InstHead l) where+ toType (Exts.IHCon _ qn) = toType qn+ toType (Exts.IHInfix _ typ qn) = TH.AppT (toType typ) (toType qn)+ toType (Exts.IHParen _ hd) = toType hd+ toType (Exts.IHApp _ hd typ) = TH.AppT (toType hd) (toType typ)++qualConDeclToCon :: Exts.QualConDecl l -> TH.Con+qualConDeclToCon (Exts.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl+qualConDeclToCon (Exts.QualConDecl _ ns cxt cdecl) = TH.ForallC (toTyVarSpec <$> toTyVars ns)+ (toCxt cxt)+ (conDeclToCon cdecl)++instance ToTyVars a => ToTyVars (Maybe a) where+ toTyVars Nothing = []+ toTyVars (Just a) = toTyVars a++instance ToTyVars a => ToTyVars [a] where+ toTyVars = concatMap toTyVars++instance ToTyVars (Exts.TyVarBind l) where+ toTyVars tvb = [toTyVar tvb]++instance ToType (Exts.QName l) where+ toType = TH.ConT . toName++conDeclToCon :: Exts.ConDecl l -> TH.Con+conDeclToCon (Exts.ConDecl _ n tys)+ = TH.NormalC (toName n) (map toStrictType tys)+conDeclToCon (Exts.RecDecl _ n fieldDecls)+ = TH.RecC (toName n) (concatMap convField fieldDecls)+ where+ convField :: Exts.FieldDecl l -> [TH.VarStrictType]+ convField (Exts.FieldDecl _ ns t) =+ let (strict, ty) = toStrictType t+ in map (\n' -> (toName n', strict, ty)) ns+conDeclToCon h = todo "conDeclToCon" h+-- TODO+-- (Exts.InfixConDecl _ _ _ _)+++hsMatchesToFunD :: [Exts.Match l] -> TH.Dec+hsMatchesToFunD [] = TH.FunD (TH.mkName []) [] -- errorish+hsMatchesToFunD xs@(Exts.Match _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs)+hsMatchesToFunD xs@(Exts.InfixMatch _ _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs)+++hsMatchToClause :: Exts.Match l -> TH.Clause+hsMatchToClause (Exts.Match _ _ ps rhs bnds) = TH.Clause+ (fmap toPat ps)+ (hsRhsToBody rhs)+ (toDecs bnds)+hsMatchToClause (Exts.InfixMatch _ p _ ps rhs bnds) = TH.Clause+ (fmap toPat (p:ps))+ (hsRhsToBody rhs)+ (toDecs bnds)++++hsRhsToBody :: Exts.Rhs l -> TH.Body+hsRhsToBody (Exts.UnGuardedRhs _ e) = TH.NormalB (toExp e)+hsRhsToBody (Exts.GuardedRhss _ hsgrhs) =+ let fromGuardedB (TH.GuardedB a) = a+ fromGuardedB h = todo "fromGuardedB" [h]+ -- TODO: (NormalB _)+ in TH.GuardedB . concat+ . fmap (fromGuardedB . hsGuardedRhsToBody)+ $ hsgrhs+++hsGuardedRhsToBody :: Exts.GuardedRhs l -> TH.Body+hsGuardedRhsToBody (Exts.GuardedRhs _ [] e) = TH.NormalB (toExp e)+hsGuardedRhsToBody (Exts.GuardedRhs _ [s] e) = TH.GuardedB [(hsStmtToGuard s, toExp e)]+hsGuardedRhsToBody (Exts.GuardedRhs _ ss e) = let ss' = fmap hsStmtToGuard ss+ (pgs,ngs) = unzip [(p,n)+ | (TH.PatG p) <- ss'+ , n@(TH.NormalG _) <- ss']+ e' = toExp e+ patg = TH.PatG (concat pgs)+ in TH.GuardedB $ (patg,e') : zip ngs (repeat e')++++hsStmtToGuard :: Exts.Stmt l -> TH.Guard+hsStmtToGuard (Exts.Generator _ p e) = TH.PatG [TH.BindS (toPat p) (toExp e)]+hsStmtToGuard (Exts.Qualifier _ e) = TH.NormalG (toExp e)+hsStmtToGuard (Exts.LetStmt _ bs) = TH.PatG [TH.LetS (toDecs bs)]+hsStmtToGuard h = todo "hsStmtToGuard" h+-- TODO+-- (Exts.RecStmt _ _)+++-----------------------------------------------------------------------------++-- * ToDecs InstDecl+instance ToDecs (Exts.InstDecl l) where+ toDecs (Exts.InsDecl _ decl) = toDecs decl+ toDecs d = todo "toDec" d++-- * ToDecs HsDecl HsBinds++instance ToDecs (Exts.Decl l) where+ toDecs _a@(Exts.TypeSig _ ns t)+ -- TODO: fixforall as before?+ -- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns+ = let xs = fmap (flip TH.SigD (toType t) . toName) ns+ in xs++ toDecs (Exts.InfixDecl l assoc Nothing ops) =+ toDecs (Exts.InfixDecl l assoc (Just 9) ops)+ toDecs (Exts.InfixDecl _ assoc (Just fixity) ops) =+#if MIN_VERSION_template_haskell(2,22,0)+ map (\op -> TH.InfixD (TH.Fixity fixity dir) TH.NoNamespaceSpecifier (toName op)) ops+#else+ map (\op -> TH.InfixD (TH.Fixity fixity dir) (toName op)) ops+#endif+ where+ dir = case assoc of+ Exts.AssocNone _ -> TH.InfixN+ Exts.AssocLeft _ -> TH.InfixL+ Exts.AssocRight _ -> TH.InfixR++ toDecs a = [toDec a]+++-- TODO: see aboe re: fixforall+-- fixForall t@(TH.ForallT _ _ _) = t+-- fixForall t = case vs of+-- [] -> t+-- _ -> TH.ForallT vs [] t+-- where vs = collectVars t+-- collectVars e = case e of+-- VarT n -> [PlainTV n]+-- AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2+-- TH.ForallT ns _ t -> collectVars t \\ ns+-- _ -> []++instance ToDecs a => ToDecs [a] where+ toDecs a = concatMap toDecs a
− src/Language/Haskell/Meta/Syntax/Vars.hs
@@ -1,168 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances,- MultiParamTypeClasses #-}-{- |- Module : Language.Haskell.Meta.Syntax.Vars- Copyright : (c) Matt Morrow 2008- License : BSD3- Maintainer : Matt Morrow <mjm2002@gmail.com>- Stability : experimental- Portability : portable (template-haskell)--}--module Language.Haskell.Meta.Syntax.Vars (- Vars(..)-) where--import Data.Set (Set)-import qualified Data.Set as S-import Language.Haskell.TH.Syntax----------------------------------------------------------------------------------class Vars e v where- vars :: (Ord v) => e -> Set v- fvs :: (Ord v) => e -> Set v- bvs :: (Ord v) => e -> Set v- vars e = fvs e `S.union` bvs e- fvs e = vars e `S.difference` bvs e- bvs e = vars e `S.difference` fvs e---instance (Vars e v) => Vars [e] v where- vars = S.unions . fmap vars- fvs = S.unions . fmap fvs- bvs = S.unions . fmap bvs-----------------------------------------------------------------------------------instance Vars Pat Name where- vars (LitP _) = S.empty- vars (VarP n) = S.singleton n- vars (TupP ps) = vars ps- vars (ConP n ps) = n `S.insert` vars ps- vars (InfixP p n q) = n `S.insert` vars [p,q]- vars (TildeP p) = vars p- vars (BangP p) = vars p- vars (AsP n p) = n `S.insert` vars p- vars (WildP) = S.empty- vars (RecP n pfs) = (n `S.insert`) . vars . fmap snd $ pfs- vars (ListP ps) = vars ps- vars (SigP p _) = vars p- bvs (LitP _) = S.empty- bvs (VarP n) = S.singleton n- bvs (TupP ps) = bvs ps- bvs (ConP _ ps) = bvs ps- bvs (InfixP p _ q) = bvs [p,q]- bvs (TildeP p) = bvs p- bvs (BangP p) = bvs p- bvs (AsP n p) = n `S.insert` bvs p- bvs (WildP) = S.empty- bvs (RecP _ pfs) = bvs . fmap snd $ pfs- bvs (ListP ps) = bvs ps- bvs (SigP p _) = bvs p---instance Vars Range Name where- vars (FromR e) = vars e- vars (FromThenR e f) = vars [e,f]- vars (FromToR e f) = vars [e,f]- vars (FromThenToR e f g) = vars [e,f,g]- fvs (FromR e) = fvs e- fvs (FromThenR e f) = fvs [e,f]- fvs (FromToR e f) = fvs [e,f]- fvs (FromThenToR e f g) = fvs [e,f,g]---instance Vars Exp Name where- vars (LamE ps e) = fvs ps `S.union` vars e- vars (LetE ds e) = fvs e `S.union` vars ds- vars e = fvs e- fvs (VarE n) = S.singleton n- fvs (ConE n) = S.singleton n- fvs (LitE _) = S.empty- fvs (AppE a b) = fvs [a,b]- fvs (InfixE aM b cM) = fvs (b : concatMap (maybe [] (:[])) [aM,cM])- fvs (LamE ps e) = fvs e `S.difference` bvs ps- fvs (TupE es) = fvs es- fvs (CondE e f g) = fvs [e,f,g]- fvs (LetE ds e) = (fvs e `S.union` fvs ds) `S.difference` bvs ds- fvs (CaseE e ms) = fvs e `S.union` fvs ms- fvs (DoE ss) = fvs ss- fvs (CompE ss) = fvs ss- fvs (ArithSeqE r) = fvs r- fvs (ListE xs) = fvs xs- fvs (SigE e _) = fvs e- fvs (RecConE n xs) = (n `S.insert`) . fvs . fmap snd $ xs- fvs (RecUpdE e xs) = fvs . (e:) . fmap snd $ xs---instance Vars Match Name where- fvs (Match p b decs) = (fvs b `S.union` fvs decs)- `S.difference` (bvs decs `S.union` bvs p)---instance Vars Dec Name where- vars (FunD n cs) = n `S.insert` vars cs- vars (ValD p bdy decs) =- vars p `S.union` vars bdy `S.union` vars decs- vars (ClassD _ _ _ _ decs) = vars decs- vars (InstanceD _ _ decs) = vars decs- vars _ = S.empty- bvs (FunD n _) = S.singleton n- bvs (ValD p _ _) = bvs p- bvs (ClassD _ _ _ _ decs) = bvs decs- bvs (InstanceD _ _ decs) = bvs decs- bvs (SigD n _) = S.singleton n- bvs _ = S.empty----- data Clause = Clause [Pat] Body [Dec]-instance Vars Clause Name where- vars (Clause ps bdy decs) =- vars ps `S.union` vars bdy `S.union` vars decs- fvs (Clause ps bdy decs) =- fvs bdy `S.difference` (bvs ps `S.union` bvs decs)----- data Body = GuardedB [(Guard, Exp)] | NormalB Exp-instance Vars Body Name where- vars (NormalB e) = vars e- vars (GuardedB xs) = S.unions- . fmap (\(g,e) -> vars g `S.union` vars e)- $ xs- fvs (NormalB e) = fvs e- fvs (GuardedB xs) = S.unions- . fmap (\(g,e) -> fvs e `S.difference` bvs g)- $ xs----- data Guard = NormalG Exp | PatG [Stmt]-instance Vars Guard Name where- vars (NormalG e) = vars e- vars (PatG ss) = vars ss- fvs (NormalG e) = fvs e- fvs (PatG ss) = fvs ss- bvs (NormalG e) = bvs e- bvs (PatG ss) = bvs ss----- data Stmt = BindS Pat Exp | LetS [Dec] | NoBindS Exp | ParS [[Stmt]]-instance Vars Stmt Name where- vars (BindS p e) = vars p `S.union` vars e- vars (LetS decs) = vars decs- vars (NoBindS e) = vars e- vars (ParS sss) = vars . concat $ sss- fvs (BindS p e) = fvs e `S.difference` bvs p- fvs (LetS decs) = fvs decs- fvs (NoBindS e) = fvs e- fvs (ParS sss) = fvs . concat $ sss- bvs (BindS p e) = bvs p- bvs (LetS decs) = bvs decs- bvs (NoBindS e) = bvs e- bvs (ParS sss) = bvs . concat $ sss--------------------------------------------------------------------------------
+ src/Language/Haskell/Meta/THCompat.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+module Language.Haskell.Meta.THCompat (+ module Language.Haskell.Meta.THCompat+) where++import Language.Haskell.TH.Syntax+++conP :: Name -> [Pat] -> Pat+#if MIN_VERSION_template_haskell(2,18,0)+conP name = ConP name []+#else+conP = ConP+#endif+++#if MIN_VERSION_template_haskell(2,17,0)+plainTV :: Name -> TyVarBndr Specificity+plainTV n = PlainTV n SpecifiedSpec+#else+plainTV :: Name -> TyVarBndr+plainTV = PlainTV+#endif+++#if MIN_VERSION_template_haskell(2,17,0)+type TyVarBndr_ flag = TyVarBndr flag+#else+type TyVarBndr_ flag = TyVarBndr+#endif
src/Language/Haskell/Meta/Utils.hs view
@@ -1,28 +1,77 @@-{-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving,- DeriveDataTypeable, PatternGuards, FlexibleContexts, FlexibleInstances,- TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-} -- | This module is a staging ground -- for to-be-organized-and-merged-nicely code. -module Language.Haskell.Meta.Utils where+module Language.Haskell.Meta.Utils (+ module Language.Haskell.Meta.Utils+) where -import Data.Typeable-import Data.Generics hiding(Fixity)-import Language.Haskell.Meta-import System.IO.Unsafe(unsafePerformIO)-import Language.Haskell.Exts.Pretty(prettyPrint)-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Lib-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Lift-import Text.PrettyPrint-import Control.Monad+import Control.Monad+import Data.Generics hiding (Fixity)+import Data.List (findIndex)+import Language.Haskell.Exts.Pretty (prettyPrint)+import Language.Haskell.Meta+import qualified Language.Haskell.Meta.THCompat as Compat (conP, plainTV)+import Language.Haskell.TH.Lib hiding (cxt)+import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Syntax+import System.IO.Unsafe (unsafePerformIO)+import Text.PrettyPrint ----------------------------------------------------------------------------- +dataDCons :: Dec -> [Con]+dataDCons (DataD _ _ _ _ cons _) = cons+dataDCons _ = [] ++decCons :: Dec -> [Con]+decCons (DataD _ _ _ _ cons _) = cons+decCons (NewtypeD _ _ _ _ con _) = [con]+decCons _ = []++#if !MIN_VERSION_template_haskell(2,21,0)+#if __GLASGOW_HASKELL__ < 900+type TyVarBndrVis = TyVarBndr_ ()+#else+type TyVarBndrVis = TyVarBndrUnit+#endif+#endif++decTyVars :: Dec -> [TyVarBndrVis]+decTyVars (DataD _ _ ns _ _ _) = ns+decTyVars (NewtypeD _ _ ns _ _ _) = ns+decTyVars (TySynD _ ns _) = ns+decTyVars (ClassD _ _ ns _ _) = ns+decTyVars _ = []+++decName :: Dec -> Maybe Name+decName (FunD n _) = Just n+decName (DataD _ n _ _ _ _) = Just n+decName (NewtypeD _ n _ _ _ _) = Just n+decName (TySynD n _ _) = Just n+decName (ClassD _ n _ _ _) = Just n+decName (SigD n _) = Just n+decName (ForeignD fgn) = Just (foreignName fgn)+decName _ = Nothing+++foreignName :: Foreign -> Name+foreignName (ImportF _ _ _ n _) = n+foreignName (ExportF _ _ n _) = n++ cleanNames :: (Data a) => a -> a cleanNames = everywhere (mkT cleanName) where cleanName :: Name -> Name@@ -31,7 +80,7 @@ | otherwise = (mkName . nameBase) n isNameU :: Name -> Bool isNameU (Name _ (NameU _)) = True- isNameU _ = False+ isNameU _ = False -- | The type passed in must have a @Show@ instance which@@ -40,7 +89,7 @@ -- but useful in general. pretty :: (Show a) => a -> String pretty a = case parseHsExp (show a) of- Left _ -> []+ Left _ -> [] Right e -> prettyPrint e @@ -55,38 +104,34 @@ gpretty = either (const []) prettyPrint . parseHsExp . gshow -instance Show ExpQ where show = show . cleanNames . unQ-instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unQ-instance Show DecQ where show = show . cleanNames . unQ-instance Show TypeQ where show = show . cleanNames . unQ-instance Show (Q String) where show = unQ-instance Show (Q Doc) where show = show . unQ--deriving instance Typeable1 Q-deriving instance Typeable QuasiQuoter-+instance Show ExpQ where show = show . cleanNames . unsafeRunQ+instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unsafeRunQ+instance Show DecQ where show = show . cleanNames . unsafeRunQ+instance Show TypeQ where show = show . cleanNames . unsafeRunQ+instance Show (Q String) where show = unsafeRunQ+instance Show (Q Doc) where show = show . unsafeRunQ --- | @unQ = unsafePerformIO . runQ@-unQ :: Q a -> a-unQ = unsafePerformIO . runQ+-- | @unsafeRunQ = unsafePerformIO . runQ@+unsafeRunQ :: Q a -> a+unsafeRunQ = unsafePerformIO . runQ nameToRawCodeStr :: Name -> String nameToRawCodeStr n = let s = showNameParens n in case nameSpaceOf n of- Just VarName -> "'"++s- Just DataName -> "'"++s+ Just VarName -> "'"++s+ Just DataName -> "'"++s Just TcClsName -> "''"++s- _ -> concat ["(mkName \"", filter (/='"') s, "\")"]+ _ -> concat ["(mkName \"", filter (/='"') s, "\")"] where showNameParens :: Name -> String- showNameParens n =- let nb = nameBase n+ showNameParens n' =+ let nb = nameBase n' in case nb of (c:_) | isSym c -> concat ["(",nb,")"]- _ -> nb+ _ -> nb isSym :: Char -> Bool- isSym = (`elem` "><.\\/!@#$%^&*-+?:|")+ isSym = (`elem` ("><.\\/!@#$%^&*-+?:|" :: [Char])) -----------------------------------------------------------------------------@@ -108,7 +153,7 @@ unForall :: Type -> Type unForall (ForallT _ _ t) = t-unForall t = t+unForall t = t functionT :: [TypeQ] -> TypeQ functionT = foldl1 (|->|)@@ -117,19 +162,24 @@ mkVarT = varT . mkName -+-- | Infinite list of names composed of lowercase letters myNames :: [Name] myNames = let xs = fmap (:[]) ['a'..'z'] ys = iterate (join (zipWith (++))) xs in fmap mkName (concat ys) +-- | Generalisation of renameTs+renameThings :: (t1 -> t2 -> a1 -> (a2, t1, t2))+ -> t1 -> t2 -> [a2] -> [a1] -> ([a2], t1, t2)+renameThings _ env new acc [] = (reverse acc, env, new)+renameThings f env new acc (t:ts) =+ let (t', env', new') = f env new t+ in renameThings f env' new' (t':acc) ts+ -- | renameT applied to a list of types renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type] -> ([Type], [(Name,Name)], [Name])-renameTs env new acc [] = (reverse acc, env, new)-renameTs env new acc (t:ts) =- let (t',env',new') = renameT env new t- in renameTs env' new' (t':acc) ts+renameTs = renameThings renameT -- | Rename type variables in the Type according to the given association -- list. Normalise constructor names (remove qualification, etc.)@@ -137,10 +187,10 @@ -- the fresh names list, and add this translation to the returned list. -- The fresh names list should be infinite; myNames is a good example. renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name])-renameT env [] _ = error "renameT: ran out of names!"+renameT _env [] _ = error "renameT: ran out of names!" renameT env (x:new) (VarT n) | Just n' <- lookup n env = (VarT n',env,x:new)- | otherwise = (VarT x, (n,x):env, new) + | otherwise = (VarT x, (n,x):env, new) renameT env new (ConT n) = (ConT (normaliseName n), env, new) renameT env new t@(TupleT {}) = (t,env,new) renameT env new ArrowT = (ArrowT,env,new)@@ -149,20 +199,17 @@ (s',env'',new'') = renameT env' new' t' in (AppT s s', env'', new'') renameT env new (ForallT ns cxt t) =- let unVarT (VarT n) = PlainTV n -- dropping kinds here- (ns',env2,new2) = renameTs env new [] (fmap (VarT . toName) ns)- ns'' = fmap unVarT ns'- renameCs env new acc [] = (reverse acc, env, new)- renameCs env new acc (ClassP n ts:cs) =- let (ts', env', new') = renameTs env new [] ts- in renameCs env' new' (ClassP (normaliseName n) ts' : acc) cs- renameCs env new acc (EqualP t1 t2:cs) =- let (t1', env', new') = renameT env new t1- (t2', env'', new'') = renameT env' new' t2- in renameCs env'' new'' (EqualP t1' t2' : acc) cs- (cxt',env3,new3) = renameCs env2 new2 [] cxt- (t',env4,new4) = renameT env3 new3 t- in (ForallT ns'' cxt' t', env4, new4)+ let (ns',env2,new2) = renameTs env new [] (fmap (VarT . toName) ns)+ ns'' = fmap unVarT ns'+ (cxt',env3,new3) = renamePreds env2 new2 [] cxt+ (t',env4,new4) = renameT env3 new3 t+ in (ForallT ns'' cxt' t', env4, new4)+ where+ unVarT (VarT n) = Compat.plainTV n+ unVarT ty = error $ "renameT: unVarT: TODO for" ++ show ty+ renamePreds = renameThings renamePred+ renamePred = renameT+renameT _ _ t = error $ "renameT: TODO for " ++ show t -- | Remove qualification, etc. normaliseName :: Name -> Name@@ -189,19 +236,6 @@ ---- | Produces pretty code suitable--- for human consumption.-deriveLiftPretty :: Name -> Q String-deriveLiftPretty n = do- decs <- deriveLift n- case (parseHsDecls . pprint . cleanNames) decs of- Left e -> fail ("deriveLiftPretty: error while prettifying code: "++e)- Right hsdecs -> return (unlines . fmap prettyPrint $ hsdecs)---- splitCon :: Con -> (Name,[Type]) splitCon c = (conName c, conTypes c) @@ -218,6 +252,10 @@ conTypes (RecC _ vts) = fmap varStrictTypeTy vts conTypes (InfixC t _ t') = fmap strictTypeTy [t,t'] conTypes (ForallC _ _ c) = conTypes c+conTypes c = error $ "conTypes: TODO for " ++ show c+-- TODO+ -- (GadtC _ _ _)+ -- (RecGadtC _ _ _) conToConType :: Type -> Con -> Type@@ -225,48 +263,19 @@ -decCons :: Dec -> [Con]-decCons (DataD _ _ _ cons _) = cons-decCons (NewtypeD _ _ _ con _) = [con]-decCons _ = [] --decTyVars :: Dec -> [TyVarBndr]-decTyVars (DataD _ _ ns _ _) = ns-decTyVars (NewtypeD _ _ ns _ _) = ns-decTyVars (TySynD _ ns _) = ns-decTyVars (ClassD _ _ ns _ _) = ns-decTyVars _ = []---decName :: Dec -> Maybe Name-decName (FunD n _) = Just n-decName (DataD _ n _ _ _) = Just n-decName (NewtypeD _ n _ _ _) = Just n-decName (TySynD n _ _) = Just n-decName (ClassD _ n _ _ _) = Just n-decName (SigD n _) = Just n-decName (ForeignD fgn) = Just (foreignName fgn)-decName _ = Nothing---foreignName :: Foreign -> Name-foreignName (ImportF _ _ _ n _) = n-foreignName (ExportF _ _ n _) = n-- unwindT :: Type -> [Type] unwindT = go where go :: Type -> [Type]- go (ForallT _ _ t) = go t+ go (ForallT _ _ t) = go t go (AppT (AppT ArrowT t) t') = t : go t'- go _ = []+ go _ = [] unwindE :: Exp -> [Exp] unwindE = go [] where go acc (e `AppE` e') = go (e':acc) e- go acc e = e:acc+ go acc e = e:acc -- | The arity of a Type.@@ -290,34 +299,39 @@ -- | Randomly useful. nameSpaceOf :: Name -> Maybe NameSpace nameSpaceOf (Name _ (NameG ns _ _)) = Just ns-nameSpaceOf _ = Nothing+nameSpaceOf _ = Nothing conName :: Con -> Name-conName (RecC n _) = n-conName (NormalC n _) = n-conName (InfixC _ n _) = n+conName (RecC n _) = n+conName (NormalC n _) = n+conName (InfixC _ n _) = n conName (ForallC _ _ con) = conName con+conName c = error $ "conName: TODO for" ++ show c+-- TODO+ -- (GadtC _ _ _)+ -- (RecGadtC _ _ _) recCName :: Con -> Maybe Name recCName (RecC n _) = Just n-recCName _ = Nothing--dataDCons :: Dec -> [Con]-dataDCons (DataD _ _ _ cons _) = cons-dataDCons _ = []+recCName _ = Nothing fromDataConI :: Info -> Q (Maybe Exp)-fromDataConI (DataConI dConN ty tyConN fxty) =+fromDataConI (DataConI dConN ty _tyConN) = let n = arityT ty in replicateM n (newName "a") >>= \ns -> return (Just (LamE- [ConP dConN (fmap VarP ns)]- (TupE $ fmap VarE ns)))+ [Compat.conP dConN (fmap VarP ns)]+#if MIN_VERSION_template_haskell(2,16,0)+ (TupE $ fmap (Just . VarE) ns)+#else+ (TupE $ fmap VarE ns)+#endif+ )) fromDataConI _ = return Nothing fromTyConI :: Info -> Maybe Dec fromTyConI (TyConI dec) = Just dec-fromTyConI _ = Nothing+fromTyConI _ = Nothing mkFunD :: Name -> [Pat] -> Exp -> Dec mkFunD f xs e = FunD f [Clause xs (NormalB e) []]@@ -338,6 +352,7 @@ -- functions you wish to use for parsing in pattern and -- expression context respectively, put them inside -- a @Quoter@ datatype and pass this to quasify.+{- data Quoter a = Quoter { expQ :: (Lift a) => String -> Q a , patQ :: (Show a) => String -> Q a }@@ -346,6 +361,7 @@ quasify q = QuasiQuoter (toExpQ (expQ q)) (toPatQ (patQ q))+ -} toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ) toExpQ parseQ = (lift =<<) . parseQ@@ -371,134 +387,12 @@ where go :: Type -> Type go (ConT n) | n == ''[] = ListT go (AppT (TupleT 1) t) = t- go (ConT n) | n == ''(,) = TupleT 2- go (ConT n) | n == ''(,,) = TupleT 3- go (ConT n) | n == ''(,,,) = TupleT 4- go (ConT n) | n == ''(,,,,) = TupleT 5- go (ConT n) | n == ''(,,,,,) = TupleT 6- go (ConT n) | n == ''(,,,,,,) = TupleT 7- go (ConT n) | n == ''(,,,,,,,) = TupleT 8- go (ConT n) | n == ''(,,,,,,,,) = TupleT 9- go (ConT n) | n == ''(,,,,,,,,,) = TupleT 10- go (ConT n) | n == ''(,,,,,,,,,,) = TupleT 11- go (ConT n) | n == ''(,,,,,,,,,,,) = TupleT 12- go (ConT n) | n == ''(,,,,,,,,,,,,) = TupleT 13- go (ConT n) | n == ''(,,,,,,,,,,,,,) = TupleT 14- go (ConT n) | n == ''(,,,,,,,,,,,,,,) = TupleT 15- go (ConT n) | n == ''(,,,,,,,,,,,,,,,) = TupleT 16- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,) = TupleT 17- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,) = TupleT 18- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,) = TupleT 19- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,) = TupleT 20- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,) = TupleT 21- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,) = TupleT 22- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,) = TupleT 23- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 24- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 25- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 26- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 27- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 28- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 29- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 30- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 31- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 32- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 33- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 34- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 35- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 36- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 37- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 38- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 39- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 40- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 41- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 42- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 43- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 44- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 45- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 46- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 47- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 48- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 49- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 50- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 51- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 52- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 53- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 54- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 55- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 56- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 57- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 58- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 59- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 60- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 61- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 62- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 63- go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 64+ go (ConT n)+ | Just m <- findIndex (== n) tupleNames = TupleT (m + 2)+ where+ tupleNames = map tupleTypeName [2 .. 64] go t = t --------------------------------------------------------------------------------------------------------------------------------------------
− src/Language/Haskell/TH/Instances/Lift.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE StandaloneDeriving, TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}--{- |- Module : Language.Haskell.TH.Instances.Lift- Copyright : (c) Matt Morrow 2008- License : BSD3- Maintainer : Matt Morrow <mjm2002@gmail.com>- Stability : experimental- Portability : portable (template-haskell)--}--module Language.Haskell.TH.Instances.Lift () where--import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Ppr-import Language.Haskell.TH.Lift (deriveLiftMany)--deriving instance Ord Exp-deriving instance Ord Dec-deriving instance Ord Stmt-deriving instance Ord Type-deriving instance Ord TyVarBndr-deriving instance Ord Pred-deriving instance Ord Kind-deriving instance Ord FamFlavour-deriving instance Ord Foreign-deriving instance Ord InlineSpec-deriving instance Ord Pragma-deriving instance Ord FunDep-deriving instance Ord Con-deriving instance Ord Body-deriving instance Ord Clause-deriving instance Ord Strict-deriving instance Ord Safety-deriving instance Ord Callconv-deriving instance Ord Guard-deriving instance Ord Range-deriving instance Ord Match-deriving instance Ord Pat-deriving instance Ord Lit--deriving instance Show Loc-deriving instance Eq Loc---- TODO: make this better-instance Ppr Loc where- ppr = showtextl . show--instance Ppr Lit where- ppr l = ppr (LitE l)--deriveLiftMany [''Body, ''Callconv, ''Clause, ''Con, ''Dec,- ''Exp, ''FamFlavour, ''Fixity, ''FixityDirection, ''Foreign, ''FunDep,- ''Guard, ''Info, ''InlineSpec, ''Kind, ''Lit, ''Match, ''Pat, ''Pragma,- ''Pred, ''Range, ''Safety, ''Stmt, ''Strict, ''Type, ''TyVarBndr]-
+ tests/Main.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import qualified Control.Monad.Fail as Fail+import Data.Data (Data, cast, gfoldl)+import Data.Functor.Const+ (Const (Const, getConst))+import qualified Language.Haskell.Exts as Exts+import qualified Language.Haskell.Exts.Extension as Extension+import qualified Language.Haskell.Exts.Parser as Parser+import Language.Haskell.Meta.Parse+import Language.Haskell.Meta.Syntax.Translate+import qualified Language.Haskell.TH as TH+import Test.HUnit (Assertion, (@?=))+import Test.Tasty+ (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (testCase)++type Test = TestTree++main :: IO ()+main = defaultMain (testGroup "unit" tests)++tests :: [Test]+tests = [ derivingClausesTest+ , typeAppTest+ , orderInTypeTuples+ ]++derivingClausesTest :: Test+derivingClausesTest = testCase "Deriving clauses preserved" $+ roundTripDecls "data Foo = Foo deriving (A, B, C)"++orderInTypeTuples :: Test+orderInTypeTuples =+ testCase "Ensure that type tuples reconstructed in proper order" $ do+ expected @?= actual+ where+ expected :: [TH.TyLit]+ expected = collectAll (toExp parsed)+ actual = [TH.StrTyLit "a", TH.StrTyLit "b"]++ parsed :: Exts.Exp Exts.SrcSpanInfo+ parsed = case Exts.parseExpWithMode mode "foo @'(\"a\", \"b\")" of+ Exts.ParseOk v -> v+ e -> error $ show e+ mode :: Exts.ParseMode+ mode = Exts.defaultParseMode {+ Exts.extensions = [+ Exts.EnableExtension Exts.TypeApplications+ , Exts.EnableExtension Exts.DataKinds+ ]+ }++collectAll :: (Data a, Data b) => a -> [b]+collectAll = ($ []) . go+ where+ go :: forall a b. (Data a, Data b) => a -> [b] -> [b]+ go = \x ->+ case cast x of+ Just x' -> (x' :)+ Nothing -> getConst $ gfoldl ap (const $ Const id) x+ where+ ap :: Data x => Const ([b] -> [b]) (x -> y) -> x -> Const ([b] -> [b]) y+ ap (Const acc) x = Const $ acc . go x++typeAppMode :: Exts.ParseMode+typeAppMode = Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.TypeApplications] }++typeAppTest :: Test+typeAppTest = testCase "Type app preserved" $+ roundTripDeclsWithMode typeAppMode "tenStr = show @Int 10"++roundTripDecls :: String -> Assertion+roundTripDecls s = do+ declsExts <- liftEither $ parseHsDecls s+ declsExts' <- liftEither $ parseDecs s >>= parseHsDecls . TH.pprint+ declsExts' @?= declsExts++roundTripDeclsWithMode :: Exts.ParseMode -> String -> Assertion+roundTripDeclsWithMode mode s = do+ declsExts <- liftEither $ parseHsDeclsWithMode mode s+ declsExts' <- liftEither $ parseDecsWithMode mode s >>= parseHsDeclsWithMode mode . TH.pprint+ declsExts' @?= declsExts++liftEither :: Fail.MonadFail m => Either String a -> m a+liftEither = either fail return
+ tests/Splices.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 904+{-# LANGUAGE TypeOperators #-}+#endif+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++#if MIN_VERSION_template_haskell(2,14,0)+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE QuantifiedConstraints #-}+#endif++-- | Tests stuff mostly by just compiling correctly+import qualified Language.Haskell.Exts.Extension as Extension+import qualified Language.Haskell.Exts.Parser as Parser+import qualified Language.Haskell.Meta as Meta++----- Testing names -----++-- Test that the unit constructor works+$(either error return $ Meta.parseDecs+ "unit :: IO ()\nunit = return ()")++-- Testing that the [] constructor works in types,+$(either error return $ Meta.parseDecs+ "nilp :: [a] -> ([] a)\nnilp [] = []")++$(either error return $ Meta.parseDecs+ "pair :: (,) Int Int\npair = (,) 1 2")+++----- Testing classes and instances -----+$(either error return $ Meta.parseDecs $ unlines+ ["class MyClass a where mymethod :: a -> b -> (a,b)"+ ,"instance MyClass Bool where mymethod a b = (a,b)"+ ])++$(either error return $ Meta.parseDecsWithMode (Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.TypeApplications] }) $ unlines+ ["tenStr :: String"+ ,"tenStr = show @Int 10"])++#if MIN_VERSION_template_haskell(2,14,0)+$(either error return $ Meta.parseDecsWithMode+ (Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.QuantifiedConstraints, Extension.EnableExtension Extension.ExplicitForAll] })+ $ unlines+ ["class (forall a. Eq a => Eq (f a)) => Eq1 f where"+ ," eq1 :: f Int -> f Int -> Bool"+ ," eq1 = (==)"+ ,""+ ,"instance Eq1 []"])+#else+$(either error return $ Meta.parseDecs $ unlines+ ["eq1 :: [Int] -> [Int] -> Bool"+ ,"eq1 = (==)"])+#endif++$(either error return $ Meta.parseDecsWithMode+ (Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.GADTs] })+ $ unlines+ [+-- Not sure why but ghc 7.10 complains that "type var a is not in scope"+ "intConstraint :: (a ~ Int) => a"+ ,"intConstraint = 3"])++-- Just to check that it works as intended+main :: IO ()+main = do+ -9 <- return $(either error return $ Meta.parseExp "-3^2 :: Int") :: IO Int+ () <- unit+ [] <- return (nilp [])+ (1,2) <- return pair+ (True,1) <- return $ mymethod True 1+ "10" <- return tenStr+ 3 <- return intConstraint+ True <- return $ eq1 [1] [1]+ return ()
+ tests/TestExamples.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++import qualified BF+import qualified Hs+import qualified HsHere+import qualified SKI++import SKI (SKI (I, K, S, (:$)))++-- Very dumb test framework+shouldBe :: (Show a, Eq a) => a -> a -> IO ()+actual `shouldBe` expected = case actual == expected of+ True -> return ()+ False -> do+ putStr "Expected: "+ print expected+ putStr "Actual: "+ print actual+ fail "Expectation failure"+++a :: Int -> String+a x = [HsHere.here| random "text" $(x + 1)+ something else|]++hereTest :: IO ()+hereTest = do+ a 3 `shouldBe` (" random \"text\" "++ show (3 + 1 :: Int) ++"\n something else")++-- TODO: better test exercising the bf quasiquoter++bfTest :: IO ()+bfTest = do+ BF.eval_ (BF.parse BF.bfHelloWorld) "" `shouldBe` "Hello World!\n"++hsTest :: IO ()+hsTest = do+ (\ [Hs.hs|b@(x,_)|] -> [Hs.hs|(b,x)|]) (42 :: Int,88 :: Int) `shouldBe` ((42,88),42)++-- TODO: better test exercising the ski quasiquoter++skiTest :: IO ()+skiTest = do+ SKI.parse "S(SS)IK(SK)" `shouldBe` ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"")++main :: IO ()+main = do+ putStrLn ""+ hereTest+ bfTest+ hsTest+ skiTest