diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +The `haskell-src-meta` Package [![Hackage](https://img.shields.io/hackage/v/haskell-src-meta.svg)](https://hackage.haskell.org/package/haskell-src-meta) [![Build Status](https://travis-ci.org/DanBurton/haskell-src-meta.svg)](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. diff --git a/examples/BF.hs b/examples/BF.hs new file mode 100644 --- /dev/null +++ b/examples/BF.hs @@ -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)], []) +-} diff --git a/examples/Hs.hs b/examples/Hs.hs new file mode 100644 --- /dev/null +++ b/examples/Hs.hs @@ -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 + } diff --git a/examples/HsHere.hs b/examples/HsHere.hs new file mode 100644 --- /dev/null +++ b/examples/HsHere.hs @@ -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 ']' diff --git a/examples/SKI.hs b/examples/SKI.hs new file mode 100644 --- /dev/null +++ b/examples/SKI.hs @@ -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 +-} diff --git a/haskell-src-meta.cabal b/haskell-src-meta.cabal --- a/haskell-src-meta.cabal +++ b/haskell-src-meta.cabal @@ -1,38 +1,88 @@ name: haskell-src-meta -version: 0.0.4 -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: Matt Morrow -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.*, containers, haskell-src-exts == 1.0.*, - packedstring, template-haskell, pretty, syb - extensions: TemplateHaskell, QuasiQuotes, - RankNTypes, StandaloneDeriving, - FlexibleInstances, FlexibleContexts, - TypeSynonymInstances, PatternGuards - DeriveDataTypeable - ghc-options: -O2 - 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.Vixey, - 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: https://github.com/haskell-party/haskell-src-meta.git diff --git a/src/Language/Haskell/Meta.hs b/src/Language/Haskell/Meta.hs --- a/src/Language/Haskell/Meta.hs +++ b/src/Language/Haskell/Meta.hs @@ -1,4 +1,3 @@ - {- | Module : Language.Haskell.Meta Copyright : (c) Matt Morrow 2008 @@ -9,11 +8,12 @@ -} module Language.Haskell.Meta ( - module Language.Haskell.Meta.Parse - , module Language.Haskell.Meta.Syntax - , module Language.Haskell.TH.Instances.Lift + 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 () diff --git a/src/Language/Haskell/Meta/Extensions.hs b/src/Language/Haskell/Meta/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Meta/Extensions.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE CPP #-} +{- | + Module : Language.Haskell.Meta.Parse + Copyright : (c) Serokell 2022, Adam Bergmark 2022 + License : BSD3 + Maintainer : Adam Bergmark + 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` + + +----------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Meta/Parse.hs b/src/Language/Haskell/Meta/Parse.hs --- a/src/Language/Haskell/Meta/Parse.hs +++ b/src/Language/Haskell/Meta/Parse.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE CPP #-} {- | Module : Language.Haskell.Meta.Parse Copyright : (c) Matt Morrow 2008 @@ -8,44 +8,69 @@ Portability : portable (template-haskell) -} -module Language.Haskell.Meta.Parse where - - -import Language.Haskell.TH.Syntax -import Language.Haskell.Meta.Syntax -import qualified Language.Haskell.Exts.Syntax as Hs -import Language.Haskell.Exts.Extension -import Language.Haskell.Exts.Fixity -import Language.Haskell.Exts.Parser -import Language.Haskell.Exts.Pretty +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.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 . fmap toDec) . 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 - ,ignoreLanguagePragmas = False - ,fixities = baseFixities} + ,baseLanguage = Haskell2010 + ,extensions = map EnableExtension myDefaultExtensions + } -myDefaultExtensions :: [Extension] +myDefaultExtensions :: [KnownExtension] myDefaultExtensions = [PostfixOperators ,QuasiQuotes ,UnicodeSyntax @@ -55,7 +80,8 @@ ,TemplateHaskell ,RankNTypes ,MultiParamTypeClasses - ,RecursiveDo] + ,RecursiveDo + ,TypeApplications] parseResultToEither :: ParseResult a -> Either String a parseResultToEither (ParseOk a) = Right a @@ -63,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 diff --git a/src/Language/Haskell/Meta/QQ/BF.hs b/src/Language/Haskell/Meta/QQ/BF.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/QQ/BF.hs +++ /dev/null @@ -1,183 +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.Ppr -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)], []) --} - - - - - - diff --git a/src/Language/Haskell/Meta/QQ/Here.hs b/src/Language/Haskell/Meta/QQ/Here.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/QQ/Here.hs +++ /dev/null @@ -1,11 +0,0 @@ - --- | Here! - -module Language.Haskell.Meta.QQ.Here (here) where - -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Lib - -here :: QuasiQuoter -here = QuasiQuoter (litE . stringL) (litP . stringL) diff --git a/src/Language/Haskell/Meta/QQ/Hs.hs b/src/Language/Haskell/Meta/QQ/Hs.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/QQ/Hs.hs +++ /dev/null @@ -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)) diff --git a/src/Language/Haskell/Meta/QQ/HsHere.hs b/src/Language/Haskell/Meta/QQ/HsHere.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/QQ/HsHere.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} - -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 ']' - diff --git a/src/Language/Haskell/Meta/QQ/SKI.hs b/src/Language/Haskell/Meta/QQ/SKI.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/QQ/SKI.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} - -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 --} - - - diff --git a/src/Language/Haskell/Meta/QQ/Vixey.hs b/src/Language/Haskell/Meta/QQ/Vixey.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/QQ/Vixey.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} - --- | Vixey's idea. - -module Language.Haskell.Meta.QQ.Vixey (vix) 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')] -vix :: QuasiQuoter -vix = 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 - - diff --git a/src/Language/Haskell/Meta/Syntax.hs b/src/Language/Haskell/Meta/Syntax.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/Syntax.hs +++ /dev/null @@ -1,19 +0,0 @@ - -{- | - Module : Language.Haskell.Meta.Syntax - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow - 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 - - diff --git a/src/Language/Haskell/Meta/Syntax/Translate.hs b/src/Language/Haskell/Meta/Syntax/Translate.hs --- a/src/Language/Haskell/Meta/Syntax/Translate.hs +++ b/src/Language/Haskell/Meta/Syntax/Translate.hs @@ -1,539 +1,828 @@ -{-# LANGUAGE TemplateHaskell, TypeSynonymInstances #-} - -{- | - Module : Language.Haskell.Meta.Syntax.Translate - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow - Stability : experimental - Portability : portable (template-haskell) --} - -module Language.Haskell.Meta.Syntax.Translate ( - module Language.Haskell.Meta.Syntax.Translate -) where - -import Data.Typeable -import Data.Generics -import Data.List (foldl') -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 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.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" - ------------------------------------------------------------------------------ - --- * 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 e = error $ errorMsg "toExp" e - - -instance ToExp Hs.Splice where - toExp (Hs.IdSplice s) = VarE (toName s) - toExp (Hs.ParenSplice e) = toExp e - - ------------------------------------------------------------------------------ - -{- -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 - -{- | -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 toName) tvbM) (fmap toType 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 - * equality constraints --} -instance ToType Hs.Asst where - toType (Hs.ClassA n ts) = foldAppT (ConT . toName $ n) (fmap toType ts) - toType a@(Hs.IParam _ _) = error $ errorMsg "toType" a - toType a@(Hs.EqualP _ _) = 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 toName ns) (toType t) - - - toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns) - = case dOrN of - Hs.DataType -> DataD (fmap toType cxt) - (toName n) - (fmap toName 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 (fmap toType cxt) - (toName n) - (fmap toName 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 - 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!" - - -{- 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 - - - - --- 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 toName ns) - (fmap toType 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 - - ------------------------------------------------------------------------------ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{- | + Module : Language.Haskell.Meta.Syntax.Translate + Copyright : (c) Matt Morrow 2008 + License : BSD3 + Maintainer : Matt Morrow + 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 diff --git a/src/Language/Haskell/Meta/Syntax/Vars.hs b/src/Language/Haskell/Meta/Syntax/Vars.hs deleted file mode 100644 --- a/src/Language/Haskell/Meta/Syntax/Vars.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} - -{- | - Module : Language.Haskell.Meta.Syntax.Vars - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow - 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 (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 (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 - - ------------------------------------------------------------------------------ diff --git a/src/Language/Haskell/Meta/THCompat.hs b/src/Language/Haskell/Meta/THCompat.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Meta/THCompat.hs @@ -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 diff --git a/src/Language/Haskell/Meta/Utils.hs b/src/Language/Haskell/Meta/Utils.hs --- a/src/Language/Haskell/Meta/Utils.hs +++ b/src/Language/Haskell/Meta/Utils.hs @@ -1,26 +1,77 @@ -{-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving, - 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 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 @@ -29,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 @@ -38,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 @@ -53,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])) ----------------------------------------------------------------------------- @@ -106,7 +153,7 @@ unForall :: Type -> Type unForall (ForallT _ _ t) = t -unForall t = t +unForall t = t functionT :: [TypeQ] -> TypeQ functionT = foldl1 (|->|) @@ -115,23 +162,36 @@ 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 -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 +-- | renameT applied to a list of types +renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type] + -> ([Type], [(Name,Name)], [Name]) +renameTs = renameThings renameT +-- | Rename type variables in the Type according to the given association +-- list. Normalise constructor names (remove qualification, etc.) +-- If a name is not found in the association list, replace it with one from +-- 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 (x:new) (VarT n) | Just n' <- lookup n env = (VarT n',env,x:new) - | otherwise = (VarT x, (n,x):env, new) -renameT env new (ConT n) = (ConT ((mkName . nameBase) n), 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) renameT env new ListT = (ListT,env,new) @@ -139,24 +199,32 @@ (s',env'',new'') = renameT env' new' t' in (AppT s s', env'', new'') renameT env new (ForallT ns cxt t) = - let unVarT (VarT n) = n - (ns',env2,new2) = renameTs env new [] (fmap VarT ns) - ns'' = fmap unVarT ns' - (cxt',env3,new3) = renameTs 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 +normaliseName = mkName . nameBase applyT :: Type -> Type -> Type applyT (ForallT [] _ t) t' = t `AppT` t' -applyT (ForallT (n:ns) cxt t) t' = ForallT ns cxt (substT [(n,t')] ns t) +applyT (ForallT (n:ns) cxt t) t' = ForallT ns cxt + (substT [(toName n,t')] (fmap toName ns) t) applyT t t' = t `AppT` t' substT :: [(Name, Type)] -> [Name] -> Type -> Type -substT env bnd (ForallT ns _ t) = substT env (ns++bnd) t +substT env bnd (ForallT ns _ t) = substT env (fmap toName ns++bnd) t substT env bnd t@(VarT n) | n `elem` bnd = t | otherwise = maybe t id (lookup n env) @@ -168,42 +236,6 @@ --- | Stolen from Igloo's th-lift. -deriveLift :: Name -> Q Dec -deriveLift n - = do i <- reify n - case i of - TyConI (DataD _ _ vs cons _) -> - let ctxt = cxt [conT ''Lift `appT` varT v | v <- vs] - typ = foldl appT (conT n) $ map varT vs - fun = funD 'lift (map doCons cons) - in instanceD ctxt (conT ''Lift `appT` typ) [fun] - _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i) - where modName :: String - modName = "Language.Haskell.TH.Utils" - doCons :: Con -> Q Clause - doCons (NormalC c sts) = do - let ns = zipWith (\_ i -> "x" ++ show i) sts [0..] - con = [| conE c |] - args = [ [| lift $(varE (mkName n)) |] | n <- ns ] - e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args - clause [conP c (map (varP . mkName) ns)] (normalB e) [] - doCons c = error (modName ++ ".doCons: Unhandled constructor: " ++ pprint c) - - - --- | 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) @@ -220,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 @@ -227,48 +263,19 @@ -decCons :: Dec -> [Con] -decCons (DataD _ _ _ cons _) = cons -decCons (NewtypeD _ _ _ con _) = [con] -decCons _ = [] - -decTyVars :: Dec -> [Name] -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. @@ -292,36 +299,46 @@ -- | 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) []] +mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ +mkClauseQ ps e = clause ps (normalB e) [] + ----------------------------------------------------------------------------- -- | The strategy for producing QuasiQuoters which @@ -335,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 } @@ -343,6 +361,7 @@ quasify q = QuasiQuoter (toExpQ (expQ q)) (toPatQ (patQ q)) + -} toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ) toExpQ parseQ = (lift =<<) . parseQ @@ -368,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 ----------------------------------------------------------------------------- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/src/Language/Haskell/TH/Instances/Lift.hs b/src/Language/Haskell/TH/Instances/Lift.hs deleted file mode 100644 --- a/src/Language/Haskell/TH/Instances/Lift.hs +++ /dev/null @@ -1,871 +0,0 @@ -{-# LANGUAGE TemplateHaskell, CPP, MagicHash, TypeSynonymInstances #-} - -{- | - Module : Language.Haskell.TH.Instances.Lift - Copyright : (c) Matt Morrow 2008 - License : BSD3 - Maintainer : Matt Morrow - Stability : experimental - Portability : portable (template-haskell) --} - -module Language.Haskell.TH.Instances.Lift () where - -import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr -import Data.PackedString -import Data.List(intercalate) -import GHC.Base - -instance Lift () where - lift () = [|()|] - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 609 -instance Show Loc where - show (Loc f p m s e) = - intercalate " " $ - ("Loc":fmap show [f,p,m]++[show s,show e]) - -instance Eq Loc where - (Loc a b c d e) == (Loc v w x y z) - = and $ [d==y,e==z] ++ - (zipWith (==) [a,b,c] [v,w,x]) - --- TODO: make this better -instance Ppr Loc where - ppr = showtextl . show -#endif - -instance Ppr Lit where - ppr l = ppr (LitE l) - --- comic relief from HERA -instance Lift Rational where lift _ = error "Rational.. what are you doing!" - -instance Lift Name where - lift (Name occName nameFlavour) = [| Name occName nameFlavour |] - -instance Lift PackedString where - lift ps = [| packString $(lift $ unpackPS ps) |] - -instance Lift NameFlavour where - lift NameS = [| NameS |] - lift (NameQ modName) = [| NameQ modName |] - lift (NameU i) = [| case $( lift (I# i) ) of - I# i' -> NameU i' |] - lift (NameL i) = [| case $( lift (I# i) ) of - I# i' -> NameL i' |] - lift (NameG nameSpace pkgName modName) - = [| NameG nameSpace pkgName modName |] - -instance Lift NameSpace where - lift VarName = [| VarName |] - lift DataName = [| DataName |] - lift TcClsName = [| TcClsName |] - - -instance Lift Dec where - lift (FunD x0 x1) - = appE - (appE - (conE - (Name (packString "FunD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (ValD x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "ValD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (DataD x0 x1 x2 x3 x4) - = appE - (appE - (appE - (appE - (appE - (conE - (Name (packString "DataD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3)) - (lift x4) - lift (NewtypeD x0 x1 x2 x3 x4) - = appE - (appE - (appE - (appE - (appE - (conE - (Name (packString "NewtypeD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3)) - (lift x4) - lift (TySynD x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "TySynD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (ClassD x0 x1 x2 x3 x4) - = appE - (appE - (appE - (appE - (appE - (conE - (Name (packString "ClassD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3)) - (lift x4) - lift (InstanceD x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "InstanceD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (SigD x0 x1) - = appE - (appE - (conE - (Name (packString "SigD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (ForeignD x0) - = appE - (conE - (Name (packString "ForeignD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Exp where - lift (VarE x0) - = appE - (conE - (Name (packString "VarE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ConE x0) - = appE - (conE - (Name (packString "ConE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (LitE x0) - = appE - (conE - (Name (packString "LitE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (AppE x0 x1) - = appE - (appE - (conE - (Name (packString "AppE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (InfixE x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "InfixE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (LamE x0 x1) - = appE - (appE - (conE - (Name (packString "LamE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (TupE x0) - = appE - (conE - (Name (packString "TupE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (CondE x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "CondE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (LetE x0 x1) - = appE - (appE - (conE - (Name (packString "LetE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (CaseE x0 x1) - = appE - (appE - (conE - (Name (packString "CaseE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (DoE x0) - = appE - (conE - (Name (packString "DoE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (CompE x0) - = appE - (conE - (Name (packString "CompE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ArithSeqE x0) - = appE - (conE - (Name (packString "ArithSeqE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ListE x0) - = appE - (conE - (Name (packString "ListE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (SigE x0 x1) - = appE - (appE - (conE - (Name (packString "SigE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (RecConE x0 x1) - = appE - (appE - (conE - (Name (packString "RecConE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (RecUpdE x0 x1) - = appE - (appE - (conE - (Name (packString "RecUpdE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Lit where - lift (CharL x0) - = appE - (conE - (Name (packString "CharL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (StringL x0) - = appE - (conE - (Name (packString "StringL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (IntegerL x0) - = appE - (conE - (Name (packString "IntegerL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (RationalL x0) - = appE - (conE - (Name (packString "RationalL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (IntPrimL x0) - = appE - (conE - (Name (packString "IntPrimL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 609 - lift (WordPrimL x0) - = appE - (conE - (Name (packString "WordPrimL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) -#endif - lift (FloatPrimL x0) - = appE - (conE - (Name (packString "FloatPrimL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (DoublePrimL x0) - = appE - (conE - (Name (packString "DoublePrimL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Pat where - lift (LitP x0) - = appE - (conE - (Name (packString "LitP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (VarP x0) - = appE - (conE - (Name (packString "VarP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (TupP x0) - = appE - (conE - (Name (packString "TupP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ConP x0 x1) - = appE - (appE - (conE - (Name (packString "ConP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (InfixP x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "InfixP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (TildeP x0) - = appE - (conE - (Name (packString "TildeP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (AsP x0 x1) - = appE - (appE - (conE - (Name (packString "AsP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (WildP) - = conE - (Name (packString "WildP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (RecP x0 x1) - = appE - (appE - (conE - (Name (packString "RecP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (ListP x0) - = appE - (conE - (Name (packString "ListP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (SigP x0 x1) - = appE - (appE - (conE - (Name (packString "SigP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Body where - lift (GuardedB x0) - = appE - (conE - (Name (packString "GuardedB") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (NormalB x0) - = appE - (conE - (Name (packString "NormalB") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Con where - lift (NormalC x0 x1) - = appE - (appE - (conE - (Name (packString "NormalC") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (RecC x0 x1) - = appE - (appE - (conE - (Name (packString "RecC") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (InfixC x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "InfixC") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (ForallC x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "ForallC") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - -instance Lift Clause where - lift (Clause x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "Clause") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - -instance Lift Guard where - lift (NormalG x0) - = appE - (conE - (Name (packString "NormalG") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (PatG x0) - = appE - (conE - (Name (packString "PatG") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Strict where - lift (IsStrict) - = conE - (Name (packString "IsStrict") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (NotStrict) - = conE - (Name (packString "NotStrict") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - -instance Lift FunDep where - lift (FunDep x0 x1) - = appE - (appE - (conE - (Name (packString "FunDep") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Foreign where - lift (ImportF x0 x1 x2 x3 x4) - = appE - (appE - (appE - (appE - (appE - (conE - (Name (packString "ImportF") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3)) - (lift x4) - lift (ExportF x0 x1 x2 x3) - = appE - (appE - (appE - (appE - (conE - (Name (packString "ExportF") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3) - -instance Lift Callconv where - lift (CCall) - = conE - (Name (packString "CCall") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (StdCall) - = conE - (Name (packString "StdCall") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - -instance Lift Safety where - lift (Unsafe) - = conE - (Name (packString "Unsafe") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (Safe) - = conE - (Name (packString "Safe") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (Threadsafe) - = conE - (Name (packString "Threadsafe") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - -instance Lift Match where - lift (Match x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "Match") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - -instance Lift Stmt where - lift (BindS x0 x1) - = appE - (appE - (conE - (Name (packString "BindS") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (LetS x0) - = appE - (conE - (Name (packString "LetS") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (NoBindS x0) - = appE - (conE - (Name (packString "NoBindS") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ParS x0) - = appE - (conE - (Name (packString "ParS") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Range where - lift (FromR x0) - = appE - (conE - (Name (packString "FromR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (FromThenR x0 x1) - = appE - (appE - (conE - (Name (packString "FromThenR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (FromToR x0 x1) - = appE - (appE - (conE - (Name (packString "FromToR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (FromThenToR x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "FromThenToR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - -instance Lift Type where - lift (ForallT x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "ForallT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (VarT x0) - = appE - (conE - (Name (packString "VarT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ConT x0) - = appE - (conE - (Name (packString "ConT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (TupleT x0) - = appE - (conE - (Name (packString "TupleT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ArrowT) - = conE - (Name (packString "ArrowT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (ListT) - = conE - (Name (packString "ListT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (AppT x0 x1) - = appE - (appE - (conE - (Name (packString "AppT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Info where - lift (ClassI x0) - = appE - (conE - (Name (packString "ClassI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ClassOpI x0 x1 x2 x3) - = appE - (appE - (appE - (appE - (conE - (Name (packString "ClassOpI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3) - lift (TyConI x0) - = appE - (conE - (Name (packString "TyConI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (PrimTyConI x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "PrimTyConI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (DataConI x0 x1 x2 x3) - = appE - (appE - (appE - (appE - (conE - (Name (packString "DataConI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3) - lift (VarI x0 x1 x2 x3) - = appE - (appE - (appE - (appE - (conE - (Name (packString "VarI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3) - lift (TyVarI x0 x1) - = appE - (appE - (conE - (Name (packString "TyVarI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Fixity where - lift (Fixity x0 x1) - = appE - (appE - (conE - (Name (packString "Fixity") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift FixityDirection where - lift (InfixL) - = conE - (Name (packString "InfixL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (InfixR) - = conE - (Name (packString "InfixR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (InfixN) - = conE - (Name (packString "InfixN") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 diff --git a/tests/Splices.hs b/tests/Splices.hs new file mode 100644 --- /dev/null +++ b/tests/Splices.hs @@ -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 () diff --git a/tests/TestExamples.hs b/tests/TestExamples.hs new file mode 100644 --- /dev/null +++ b/tests/TestExamples.hs @@ -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