diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +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 diff --git a/examples/BF.hs b/examples/BF.hs --- a/examples/BF.hs +++ b/examples/BF.hs @@ -1,24 +1,46 @@ -{-# LANGUAGE BangPatterns, TemplateHaskell #-} +-- TODO: knock out these warnings +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} module BF ( - bf,bf2,bfHelloWorld,eval_,parse + bf,bf2,bfHelloWorld,eval_,parse, exec, test0 ) where -import Language.Haskell.Meta (parsePat) +import Language.Haskell.Meta (parsePat) import Language.Haskell.TH.Lib import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax -import Data.Char -import Data.IntMap(IntMap) -import qualified Data.IntMap as IM +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 } +bf = QuasiQuoter + { quoteExp = bfExpQ + , quotePat = bfPatQ + , quoteType = quoteTypeNotImplemented + , quoteDec = quoteDecNotImplemented + } bf2 :: QuasiQuoter -bf2 = QuasiQuoter { quoteExp = bf2ExpQ, quotePat = bfPatQ } +bf2 = QuasiQuoter + { quoteExp = bf2ExpQ + , quotePat = bfPatQ + , quoteType = quoteTypeNotImplemented + , quoteDec = quoteDecNotImplemented + } bf2ExpQ :: String -> ExpQ bf2ExpQ s = [|eval (parse s)|] @@ -32,16 +54,16 @@ . show . parse) s case p of - Left e -> fail e + 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 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 @@ -133,7 +155,7 @@ go !n acc (c :cs) k = go n acc cs k - +test0 :: IO [Bf] test0 = do a <- readFile "prime.bf" return (parse a) diff --git a/examples/Hs.hs b/examples/Hs.hs --- a/examples/Hs.hs +++ b/examples/Hs.hs @@ -4,12 +4,22 @@ module Hs (hs, pat) where -import Language.Haskell.Meta (parseExp, parsePat) +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) @@ -19,6 +29,8 @@ hs = QuasiQuoter { quoteExp = either fail transformE . parseExp , quotePat = either fail transformP . parsePat + , quoteType = quoteTypeNotImplemented + , quoteDec = quoteDecNotImplemented } transformE :: Exp -> ExpQ @@ -32,5 +44,7 @@ { quoteExp = quoteExp hs , quotePat = \s -> case parseExp s of Left err -> fail err - Right e -> either fail return (parsePat . pretty $ e) + Right e -> either fail return (parsePat . pretty $ e) + , quoteType = quoteTypeNotImplemented + , quoteDec = quoteDecNotImplemented } diff --git a/examples/HsHere.hs b/examples/HsHere.hs --- a/examples/HsHere.hs +++ b/examples/HsHere.hs @@ -1,17 +1,42 @@ -{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-} +-- TODO: knock out these warnings +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} -module HsHere (here) where +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TemplateHaskell #-} -import Language.Haskell.Meta (parseExp, parsePat) -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 (cleanNames) -import Text.ParserCombinators.ReadP -import Data.Typeable(Typeable) -import Data.Generics(Data) +module HsHere + ( here + , lexemeP + , nestedP + , parensP + , bracksP + , oparenP + , obrackP + , cbrackP + ) where +import qualified Control.Monad.Fail as Fail +import Data.Generics (Data) +import Data.Typeable (Typeable) +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 @@ -28,8 +53,8 @@ -- > a x = " random \"text\" "++ show (x + 1) ++"\n something else" here :: QuasiQuoter here = QuasiQuoter - {quoteType = fail "The here quoter is only for expressions and patterns" - ,quoteDec = fail "The here quoter is only for expressions and patterns" + {quoteType = quoteTypeNotImplemented + ,quoteDec = quoteDecNotImplemented ,quoteExp = hereExpQ ,quotePat = herePatQ} @@ -44,7 +69,7 @@ hereExpQ :: String -> ExpQ hereExpQ s = case run s of - [] -> fail "here: parse error" + [] -> fail "here: parse error" e:_ -> lift (cleanNames e) herePatQ :: String -> PatQ @@ -54,7 +79,7 @@ . pprint . cleanNames) e case p of - Left e -> fail e + Left e -> fail e Right p -> return p run :: String -> [Here] @@ -83,7 +108,8 @@ | c:s <- s = do skip 1 (TextH . (c:)) `fmap` munch (not.(`elem`"\\$")) - where go _ acc [] = return (TextH (reverse acc)) + 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 @@ -107,8 +133,10 @@ 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 '[' diff --git a/examples/SKI.hs b/examples/SKI.hs --- a/examples/SKI.hs +++ b/examples/SKI.hs @@ -1,18 +1,43 @@ -{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-} +-- 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 #-} -module SKI (SKI(..),ski,parse) where +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TemplateHaskell #-} -import Language.Haskell.Meta (parseExp, parsePat) -import Language.Haskell.TH.Lib hiding (parensP) -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unsafeRunQ) -import Text.ParserCombinators.ReadP -import Data.Typeable(Typeable) -import Data.Generics(Data) -import Text.PrettyPrint(render) +module SKI + ( SKI(..) + , ski + , parse + , bracksP + , obrackP + , cbrackP + ) where +import qualified Control.Monad.Fail as Fail +import Data.Generics (Data) +import Data.Typeable (Typeable) +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,Typeable) @@ -37,18 +62,21 @@ ski :: QuasiQuoter ski = QuasiQuoter - {quoteExp = skiExpQ - ,quotePat = skiPatQ} + { quoteExp = skiExpQ + , quotePat = skiPatQ + , quoteType = quoteTypeNotImplemented + , quoteDec = quoteDecNotImplemented + } 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|] + 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 @@ -64,7 +92,7 @@ skiExpQ :: String -> ExpQ skiExpQ s = case run s of - [] -> fail "ski: parse error" + [] -> fail "ski: parse error" e:_ -> lift (cleanNames e) skiPatQ :: String -> PatQ @@ -74,7 +102,7 @@ . pprint . cleanNames) e case p of - Left e -> fail e + Left e -> fail e Right p -> return p -- ghci> parse "S(SS)IK(SK)" diff --git a/haskell-src-meta.cabal b/haskell-src-meta.cabal --- a/haskell-src-meta.cabal +++ b/haskell-src-meta.cabal @@ -1,5 +1,5 @@ name: haskell-src-meta -version: 0.8.2 +version: 0.8.3 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -9,7 +9,7 @@ copyright: (c) Matt Morrow maintainer: danburton.email@gmail.com bug-reports: https://github.com/DanBurton/haskell-src-meta/issues -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.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. @@ -21,7 +21,7 @@ haskell-src-exts >= 1.18 && < 1.22, pretty >= 1.0 && < 1.2, syb >= 0.1 && < 0.8, - template-haskell >= 2.8 && < 2.15, + template-haskell >= 2.8 && < 2.16, th-orphans >= 0.9.1 && < 0.14 if impl(ghc < 7.8) @@ -44,10 +44,16 @@ haskell-src-exts >= 1.17 && < 1.22, haskell-src-meta, pretty >= 1.0 && < 1.2, - template-haskell >= 2.7 && < 2.15, - test-framework >= 0.8 && < 0.9, - test-framework-hunit >= 0.3 && < 0.4 + template-haskell >= 2.7, + tasty, + tasty-hunit + -- this is needed to access Control.Monad.Fail on GHCs before 8.0 + if !impl(ghc >= 8.0) + Build-Depends: + fail == 4.9.* + + test-suite splices type: exitcode-stdio-1.0 hs-source-dirs: tests @@ -71,6 +77,12 @@ pretty, syb, template-haskell + + -- this is needed to access Control.Monad.Fail on GHCs before 8.0 + if !impl(ghc >= 8.0) + Build-Depends: + fail == 4.9.* + other-modules: BF, 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 @@ -14,4 +14,4 @@ import Language.Haskell.Meta.Parse import Language.Haskell.Meta.Syntax.Translate -import Language.Haskell.TH.Instances() +import Language.Haskell.TH.Instances () 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 @@ -30,24 +30,17 @@ ) where #if MIN_VERSION_template_haskell(2,11,0) -import Language.Haskell.TH.Syntax hiding (Extension(..)) +import Language.Haskell.TH.Syntax hiding (Extension (..)) #else import Language.Haskell.TH.Syntax #endif -import Language.Haskell.Meta.Syntax.Translate -#if MIN_VERSION_haskell_src_exts(1,18,0) -import qualified Language.Haskell.Exts.Syntax as Hs -import Language.Haskell.Exts.Fixity as Fix -import Language.Haskell.Exts.Parser hiding (parseExp, parseType, parsePat) -#else -import qualified Language.Haskell.Exts.Annotated.Syntax as Hs -import Language.Haskell.Exts.Annotated.Fixity as Fix -import Language.Haskell.Exts.Annotated.Parser hiding (parseExp, parseType, parsePat) -#endif -import qualified Language.Haskell.Exts.SrcLoc as Hs -import Language.Haskell.Exts.Extension -import Language.Haskell.Exts.Pretty -import Language.Haskell.Exts.Parser (ParseMode(..), ParseResult(..)) +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 ----------------------------------------------------------------------------- @@ -128,6 +121,10 @@ 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 [] [] @@ -141,6 +138,7 @@ [] []) +noSrcSpanInfo :: Hs.SrcSpanInfo noSrcSpanInfo = Hs.noInfoSpan (Hs.mkSrcSpan Hs.noLoc Hs.noLoc) {- 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,4 +1,7 @@ -{-# LANGUAGE CPP, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} {- | Module : Language.Haskell.Meta.Syntax.Translate @@ -13,50 +16,45 @@ module Language.Haskell.Meta.Syntax.Translate ) where -import Data.Char (ord) -import Data.Typeable -import Data.List (foldl', nub, (\\)) -import Language.Haskell.TH.Syntax -import qualified Language.Haskell.Exts.SrcLoc as Hs -#if MIN_VERSION_haskell_src_exts(1,18,0) -import qualified Language.Haskell.Exts.Syntax as Hs -#else -import qualified Language.Haskell.Exts.Annotated.Syntax as Hs -#endif +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 qualified Language.Haskell.TH.Syntax as TH ----------------------------------------------------------------------------- -class ToName a where toName :: a -> Name -class ToNames a where toNames :: a -> [Name] -class ToLit a where toLit :: a -> Lit -class ToType a where toType :: a -> Type -class ToPat a where toPat :: a -> Pat -class ToExp a where toExp :: a -> Exp -class ToDecs a where toDecs :: a -> [Dec] -class ToDec a where toDec :: a -> Dec -class ToStmt a where toStmt :: a -> Stmt -class ToLoc a where toLoc :: a -> Loc -class ToCxt a where toCxt :: a -> Cxt -class ToPred a where toPred :: a -> Pred -class ToTyVars a where toTyVars :: a -> [TyVarBndr] -#if MIN_VERSION_haskell_src_exts(1,18,0) -class ToMaybeKind a where toMaybeKind :: a -> Maybe Kind -#endif +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 -> [TH.TyVarBndr] +class ToMaybeKind a where toMaybeKind :: a -> Maybe TH.Kind #if MIN_VERSION_template_haskell(2,11,0) -class ToInjectivityAnn a where toInjectivityAnn :: a -> InjectivityAnn +class ToInjectivityAnn a where toInjectivityAnn :: a -> TH.InjectivityAnn #endif #if MIN_VERSION_template_haskell(2,12,0) +type DerivClause = TH.DerivClause #elif MIN_VERSION_template_haskell(2,11,0) -type DerivClause = Pred +type DerivClause = TH.Pred #else -type DerivClause = Name +type DerivClause = TH.Name #endif 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. @@ -80,42 +78,42 @@ ----------------------------------------------------------------------------- -instance ToExp Lit where - toExp = LitE +instance ToExp TH.Lit where + toExp = TH.LitE instance (ToExp a) => ToExp [a] where - toExp = ListE . fmap toExp + toExp = TH.ListE . fmap toExp instance (ToExp a, ToExp b) => ToExp (a,b) where - toExp (a,b) = TupE [toExp a, toExp b] + toExp (a,b) = TH.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] + toExp (a,b,c) = TH.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] + toExp (a,b,c,d) = TH.TupE [toExp a, toExp b, toExp c, toExp d] -instance ToPat Lit where - toPat = LitP +instance ToPat TH.Lit where + toPat = TH.LitP instance (ToPat a) => ToPat [a] where - toPat = ListP . fmap toPat + toPat = TH.ListP . fmap toPat instance (ToPat a, ToPat b) => ToPat (a,b) where - toPat (a,b) = TupP [toPat a, toPat b] + 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) = TupP [toPat a, toPat b, toPat c] + 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) = TupP [toPat a, toPat b, toPat c, toPat d] + toPat (a,b,c,d) = TH.TupP [toPat a, toPat b, toPat c, toPat d] instance ToLit Char where - toLit = CharL + toLit = TH.CharL instance ToLit String where - toLit = StringL + toLit = TH.StringL instance ToLit Integer where - toLit = IntegerL + toLit = TH.IntegerL instance ToLit Int where - toLit = IntegerL . toInteger + toLit = TH.IntegerL . toInteger instance ToLit Float where - toLit = RationalL . toRational + toLit = TH.RationalL . toRational instance ToLit Double where - toLit = RationalL . toRational + toLit = TH.RationalL . toRational ----------------------------------------------------------------------------- @@ -125,35 +123,51 @@ instance ToName String where - toName = mkName + toName = TH.mkName -instance ToName (Hs.Name l) where - toName (Hs.Ident _ s) = toName s - toName (Hs.Symbol _ s) = toName s +instance ToName (Exts.Name l) where + toName (Exts.Ident _ s) = toName s + toName (Exts.Symbol _ s) = toName s -instance ToName (Hs.SpecialCon l) where - toName (Hs.UnitCon _) = mkName "()" - toName (Hs.ListCon _) = ''[] -- Parser only uses this in types - toName (Hs.FunCon _) = ''(->) - toName (Hs.TupleCon _ _ n) = - mkName $ concat ["(",replicate (n-1) ',',")"] - toName (Hs.Cons _) = '(:) +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 (Hs.QName l) where --- toName (Hs.Qual (Hs.Module []) n) = toName n - toName (Hs.Qual _ (Hs.ModuleName _ []) n) = toName n - toName (Hs.Qual _ (Hs.ModuleName _ m) n) = +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 (Hs.UnQual _ n) = toName n - toName (Hs.Special _ s) = toName s + 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 (Hs.Op l) where - toName (Hs.VarOp _ n) = toName n - toName (Hs.ConOp _ n) = toName n +instance ToName (Exts.Op l) where + toName (Exts.VarOp _ n) = toName n + toName (Exts.ConOp _ n) = toName n ----------------------------------------------------------------------------- @@ -161,19 +175,19 @@ -- * ToLit HsLiteral -instance ToLit (Hs.Literal l) 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 l@Hs.PrimChar{} = noTH "toLit" l - toLit (Hs.PrimString _ a _) = StringPrimL (map toWord8 a) +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 . ord - toLit (Hs.PrimInt _ a _) = IntPrimL a - toLit (Hs.PrimFloat _ a _) = FloatPrimL a - toLit (Hs.PrimDouble _ a _) = DoublePrimL a - toLit (Hs.PrimWord _ a _) = WordPrimL a + 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 ----------------------------------------------------------------------------- @@ -181,249 +195,294 @@ -- * ToPat HsPat -instance ToPat (Hs.Pat l) where - toPat (Hs.PVar _ n) - = VarP (toName n) - toPat (Hs.PLit _ (Hs.Signless _) l) - = LitP (toLit l) - toPat (Hs.PLit _ (Hs.Negative _) l) = LitP $ case toLit l of - IntegerL z -> IntegerL (negate z) - RationalL q -> RationalL (negate q) - IntPrimL z' -> IntPrimL (negate z') - FloatPrimL r' -> FloatPrimL (negate r') - DoublePrimL r'' -> DoublePrimL (negate r'') - _ -> nonsense "toPat" "negating wrong kind of literal" l - toPat (Hs.PInfixApp _ p n q) = UInfixP (toPat p) (toName n) (toPat q) - toPat (Hs.PApp _ n ps) = ConP (toName n) (fmap toPat ps) - toPat (Hs.PTuple _ Hs.Boxed ps) = TupP (fmap toPat ps) - toPat (Hs.PTuple _ Hs.Unboxed ps) = UnboxedTupP (fmap toPat ps) - toPat (Hs.PList _ ps) = ListP (fmap toPat ps) - toPat (Hs.PParen _ p) = ParensP (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.PViewPat _ e p) = ViewP (toExp e) (toPat p) +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) = TH.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@Hs.PRPat{} = noTH "toPat" p + toPat p@Exts.PRPat{} = noTH "toPat" p -- XML stuff - toPat p@Hs.PXTag{} = noTH "toPat" p - toPat p@Hs.PXETag{} = noTH "toPat" p - toPat p@Hs.PXPcdata{} = noTH "toPat" p - toPat p@Hs.PXPatTag{} = noTH "toPat" p - toPat (Hs.PBangPat _ p) = BangP (toPat p) + 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 (Hs.QOp l) where - toExp (Hs.QVarOp _ n) = VarE (toName n) - toExp (Hs.QConOp _ n) = ConE (toName n) +instance ToExp (Exts.QOp l) where + toExp (Exts.QVarOp _ n) = TH.VarE (toName n) + toExp (Exts.QConOp _ n) = TH.ConE (toName n) -toFieldExp :: Hs.FieldUpdate l -> FieldExp -toFieldExp (Hs.FieldUpdate _ n e) = (toName n, toExp e) +toFieldExp :: Exts.FieldUpdate l -> TH.FieldExp +toFieldExp (Exts.FieldUpdate _ n e) = (toName n, toExp e) +toFieldExp h = todo "toFieldExp" h -instance ToExp (Hs.Exp l) where - toExp (Hs.Var _ n) = VarE (toName n) - toExp e@Hs.IPVar{} = noTH "toExp" e - toExp (Hs.Con _ n) = ConE (toName n) - toExp (Hs.Lit _ l) = LitE (toLit l) - toExp (Hs.InfixApp _ e o f) = UInfixE (toExp e) (toExp o) (toExp f) +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) + toExp (Exts.InfixApp _ e o f) = TH.UInfixE (toExp e) (toExp o) (toExp f) #if MIN_VERSION_template_haskell(2,12,0) - toExp (Hs.App _ e (Hs.TypeApp _ t)) = AppTypeE (toExp e) (toType t) + toExp (Exts.App _ e (Exts.TypeApp _ t)) = TH.AppTypeE (toExp e) (toType t) #else - toExp (Hs.App _ e aTypeApp@Hs.TypeApp{}) = noTHyet "toExp" "2.12.0" aTypeApp + toExp (Exts.App _ _ e@Exts.TypeApp{}) = noTHyet "toExp" "2.12.0" e #endif - 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 (toDecs bs) (toExp e) - toExp (Hs.If _ a b c) = CondE (toExp a) (toExp b) (toExp c) - toExp (Hs.MultiIf _ ifs) = MultiIfE (map toGuard ifs) - toExp (Hs.Case _ e alts) = CaseE (toExp e) (map toMatch alts) - toExp (Hs.Do _ ss) = DoE (map toStmt ss) - toExp e@(Hs.MDo _ _) = noTH "toExp" e - toExp (Hs.Tuple _ Hs.Boxed xs) = TupE (fmap toExp xs) - toExp (Hs.Tuple _ Hs.Unboxed xs) = UnboxedTupE (fmap toExp xs) - toExp e@Hs.TupleSection{} = noTH "toExp" e - toExp (Hs.List _ xs) = ListE (fmap toExp xs) - toExp (Hs.Paren _ e) = ParensE (toExp e) - 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.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.ListComp _ e ss) = CompE $ map convert ss ++ [NoBindS (toExp e)] + 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) + toExp (Exts.Do _ ss) = TH.DoE (map toStmt ss) + toExp e@Exts.MDo{} = noTH "toExp" e + toExp (Exts.Tuple _ Exts.Boxed xs) = TH.TupE (fmap toExp xs) + toExp (Exts.Tuple _ Exts.Unboxed xs) = TH.UnboxedTupE (fmap toExp 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 (Hs.QualStmt _ st) = toStmt st - convert s = noTH "toExp ListComp" s - toExp (Hs.ExpTypeSig _ e t) = SigE (toExp e) (toType t) + 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 :: Hs.Alt l -> Match -toMatch (Hs.Alt _ p rhs ds) = Match (toPat p) (toBody rhs) (toDecs ds) +toMatch :: Exts.Alt l -> TH.Match +toMatch (Exts.Alt _ p rhs ds) = TH.Match (toPat p) (toBody rhs) (toDecs ds) -toBody :: Hs.Rhs l -> Body -toBody (Hs.UnGuardedRhs _ e) = NormalB $ toExp e -toBody (Hs.GuardedRhss _ rhss) = GuardedB $ map toGuard rhss +toBody :: Exts.Rhs l -> TH.Body +toBody (Exts.UnGuardedRhs _ e) = TH.NormalB $ toExp e +toBody (Exts.GuardedRhss _ rhss) = TH.GuardedB $ map toGuard rhss -toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e) +toGuard :: Exts.GuardedRhs l -> (TH.Guard, TH.Exp) +toGuard (Exts.GuardedRhs _ stmts e) = (g, toExp e) where g = case map toStmt stmts of - [NoBindS x] -> NormalG x - xs -> PatG xs + [TH.NoBindS x] -> TH.NormalG x + xs -> TH.PatG xs instance ToDecs a => ToDecs (Maybe a) where - toDecs Nothing = [] + toDecs Nothing = [] toDecs (Just a) = toDecs a -instance ToDecs (Hs.Binds l) where - toDecs (Hs.BDecls _ ds) = toDecs ds - toDecs a@(Hs.IPBinds {}) = noTH "ToDecs Hs.Binds" a +instance ToDecs (Exts.Binds l) where + toDecs (Exts.BDecls _ ds) = toDecs ds + toDecs a@(Exts.IPBinds {}) = noTH "ToDecs Exts.Binds" a -instance ToDecs (Hs.ClassDecl l) where - toDecs (Hs.ClsDecl _ d) = toDecs d - toDecs x = todo "classDecl" x +instance ToDecs (Exts.ClassDecl l) where + toDecs (Exts.ClsDecl _ d) = toDecs d + toDecs x = todo "classDecl" x ----------------------------------------------------------------------------- -- * ToLoc SrcLoc -instance ToLoc Hs.SrcLoc where - toLoc (Hs.SrcLoc fn l c) = - Loc fn [] [] (l,c) (-1,-1) +instance ToLoc Exts.SrcLoc.SrcLoc where + toLoc (Exts.SrcLoc.SrcLoc fn l c) = + TH.Loc fn [] [] (l,c) (-1,-1) ----------------------------------------------------------------------------- -- * ToType HsType -instance ToName (Hs.TyVarBind l) where - toName (Hs.KindedVar _ n _) = toName n - toName (Hs.UnkindedVar _ n) = toName n +instance ToName (Exts.TyVarBind l) where + toName (Exts.KindedVar _ n _) = toName n + toName (Exts.UnkindedVar _ n) = toName n -instance ToName Name where +instance ToName TH.Name where toName = id -instance ToName TyVarBndr where - toName (PlainTV n) = n - toName (KindedTV n _) = n +instance ToName TH.TyVarBndr where + toName (TH.PlainTV n) = n + toName (TH.KindedTV n _) = n #if !MIN_VERSION_haskell_src_exts(1,21,0) -instance ToType (Hs.Kind l) where - toType (Hs.KindStar _) = StarT - toType (Hs.KindFn _ k1 k2) = toType k1 .->. toType k2 - toType (Hs.KindParen _ kp) = toType kp - toType (Hs.KindVar _ n) = VarT (toName n) +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 :: Hs.Kind l -> Kind +toKind :: Exts.Kind l -> TH.Kind toKind = toType -toTyVar :: Hs.TyVarBind l -> TyVarBndr -toTyVar (Hs.KindedVar _ n k) = KindedTV (toName n) (toKind k) -toTyVar (Hs.UnkindedVar _ n) = PlainTV (toName n) +toTyVar :: Exts.TyVarBind l -> TH.TyVarBndr +toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) (toKind k) +toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n) -instance ToType (Hs.Type l) where - toType (Hs.TyForall _ tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t) - toType (Hs.TyFun _ a b) = toType a .->. toType b - toType (Hs.TyList _ t) = ListT `AppT` toType t - toType (Hs.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts) +instance ToType (Exts.Type l) where + toType (Exts.TyForall _ tvbM cxt t) = TH.ForallT (maybe [] (fmap 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 - Hs.Boxed -> TupleT - Hs.Unboxed -> UnboxedTupleT - 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 + 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) - toType (Hs.TyInfix _ a (Hs.UnpromotedName _ o) b) = + -- 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 (Hs.TyInfix _ a o b) = + toType (Exts.TyInfix _ a o b) = + TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b) #endif - AppT (AppT (ConT (toName o)) (toType a)) (toType b) - toType (Hs.TyKind _ t k) = SigT (toType t) (toKind k) - toType t@Hs.TyBang{} = + 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 -> foldr (\t pt -> pt `TH.AppT` toType t) (TH.PromotedTupleT $ length ts) ts + Exts.PromotedUnit _ -> TH.PromotedT ''() +#if MIN_VERSION_template_haskell(2,10,0) + toType (Exts.TyEquals _ t1 t2) = TH.EqualityT `TH.AppT` toType t1 `TH.AppT` toType t2 +#else + toType t@Exts.TyEquals{} = noTHyet "toType" "2.10.0" t +#endif + 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 :: Hs.Type l -> StrictType +toStrictType :: Exts.Type l -> TH.StrictType #if MIN_VERSION_template_haskell(2,11,0) -toStrictType (Hs.TyBang _ s u t) = (Bang (toUnpack u) (toStrict s), toType t) +toStrictType (Exts.TyBang _ s u t) = (TH.Bang (toUnpack u) (toStrict s), toType t) where - toStrict (Hs.LazyTy _) = SourceLazy - toStrict (Hs.BangedTy _) = SourceStrict - toStrict (Hs.NoStrictAnnot _) = NoSourceStrictness - toUnpack (Hs.Unpack _) = SourceUnpack - toUnpack (Hs.NoUnpack _) = SourceNoUnpack - toUnpack (Hs.NoUnpackPragma _) = NoSourceUnpackedness -toStrictType x = (Bang NoSourceUnpackedness NoSourceStrictness, toType x) -#elif MIN_VERSION_haskell_src_exts(1,18,0) + 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) +#else +-- TODO: what is this comment? Outdated? -- TyBang l (BangType l) (Unpackedness l) (Type l) --- data BangType l = BangedTy l | LazyTy l | NoStrictAnnot l +-- data BangType l = BangedTy l | LazyTy l | NoStrictAnnot l -- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l -toStrictType (Hs.TyBang _ b u t) = (toStrict b u, toType t) +toStrictType (Exts.TyBang _ b u t) = (toStrict b u, toType t) where - toStrict :: Hs.BangType l -> Hs.Unpackedness l -> Strict - toStrict (Hs.BangedTy _) _ = IsStrict - toStrict _ (Hs.Unpack _) = Unpacked - toStrict _ _ = NotStrict -toStrictType x = (NotStrict, toType x) -#else -toStrictType t@(Hs.TyBang _ _ Hs.TyBang{}) = - nonsense "toStrictType" "double strictness annotation" t -toStrictType (Hs.TyBang _ (Hs.BangedTy _) t) = (IsStrict, toType t) -toStrictType (Hs.TyBang _ (Hs.UnpackedTy _) t) = (Unpacked, toType t) -toStrictType t = (NotStrict, toType t) + toStrict :: Exts.BangType l -> Exts.Unpackedness l -> TH.Strict + toStrict (Exts.BangedTy _) _ = TH.IsStrict + toStrict _ (Exts.Unpack _) = TH.Unpacked + toStrict _ _ = TH.NotStrict +toStrictType x = (TH.NotStrict, toType x) #endif - -(.->.) :: Type -> Type -> Type -a .->. b = AppT (AppT ArrowT a) b +(.->.) :: TH.Type -> TH.Type -> TH.Type +a .->. b = TH.AppT (TH.AppT TH.ArrowT a) b -instance ToPred (Hs.Asst l) where +instance ToPred (Exts.Asst l) where #if MIN_VERSION_template_haskell(2,10,0) - toPred (Hs.ClassA _ n ts) = foldl' AppT (ConT (toName n)) (fmap toType ts) - toPred (Hs.InfixA _ t1 n t2) = foldl' AppT (ConT (toName n)) (fmap toType [t1,t2]) - toPred (Hs.EqualP _ t1 t2) = foldl' AppT EqualityT (fmap toType [t1,t2]) + 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]) #else - toPred (Hs.ClassA _ n ts) = ClassP (toName n) (fmap toType ts) - toPred (Hs.InfixA _ t1 n t2) = ClassP (toName n) (fmap toType [t1, t2]) - toPred (Hs.EqualP _ t1 t2) = EqualP (toType t1) (toType t2) + toPred (Exts.ClassA _ n ts) = TH.ClassP (toName n) (fmap toType ts) + toPred (Exts.InfixA _ t1 n t2) = TH.ClassP (toName n) (fmap toType [t1, t2]) + toPred (Exts.EqualP _ t1 t2) = TH.EqualP (toType t1) (toType t2) #endif - toPred a@Hs.IParam{} = noTH "toCxt" a - toPred p = todo "toPred" p + toPred (Exts.ParenA _ asst) = toPred asst + toPred a@Exts.AppA{} = todo "toPred" a + toPred a@Exts.WildCardA{} = todo "toPred" a + 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_template_haskell(2,12,0) -instance ToDerivClauses (Hs.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0) - toDerivClauses (Hs.Deriving _ strat irules) = [DerivClause (fmap toDerivStrategy strat) (map toType irules)] + toDerivClauses (Exts.Deriving _ strat irules) = [TH.DerivClause (fmap toDerivStrategy strat) (map toType irules)] #else - toDerivClauses (Hs.Deriving _ irules) = [DerivClause Nothing (map toType irules)] + toDerivClauses (Exts.Deriving _ irules) = [TH.DerivClause Nothing (map toType irules)] #endif -#else -instance ToDerivClauses (Hs.Deriving l) where +#elif MIN_VERSION_template_haskell(2,11,0) #if MIN_VERSION_haskell_src_exts(1,20,0) - toDerivClauses (Hs.Deriving _ _ irules) = + toDerivClauses (Exts.Deriving _ _ irules) = map toType irules #else - toDerivClauses (Hs.Deriving _ irules) = + toDerivClauses (Exts.Deriving _ irules) = map toType irules #endif -#if MIN_VERSION_template_haskell(2,11,0) - map toType irules #else - concatMap toNames irules +-- template-haskell < 2.11 +#if MIN_VERSION_haskell_src_exts(1,20,0) + toDerivClauses (Exts.Deriving _ _ irules) = concatMap toNames irules +#else + toDerivClauses (Exts.Deriving _ irules) = concatMap toNames irules #endif #endif @@ -434,38 +493,64 @@ instance ToDerivClauses a => ToDerivClauses [a] where toDerivClauses = concatMap toDerivClauses + #if MIN_VERSION_template_haskell(2,12,0) && MIN_VERSION_haskell_src_exts(1,20,0) -toDerivStrategy :: (Hs.DerivStrategy l) -> DerivStrategy -toDerivStrategy (Hs.DerivStock _) = StockStrategy -toDerivStrategy (Hs.DerivAnyclass _) = AnyclassStrategy -toDerivStrategy (Hs.DerivNewtype _) = NewtypeStrategy +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) +#if 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 +#endif -foldAppT :: Type -> [Type] -> Type -foldAppT t ts = foldl' AppT t ts +#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 (Hs.Stmt l) where - toStmt (Hs.Generator _ p e) = BindS (toPat p) (toExp e) - toStmt (Hs.Qualifier _ e) = NoBindS (toExp e) - toStmt a@(Hs.LetStmt _ bnds) = LetS (toDecs bnds) - toStmt s@Hs.RecStmt{} = noTH "toStmt" s +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 (Hs.Decl l) where - toDec (Hs.TypeDecl _ h t) - = TySynD (toName h) (toTyVars h) (toType t) +instance ToDec (Exts.Decl l) where + toDec (Exts.TypeDecl _ h t) + = TH.TySynD (toName h) (toTyVars h) (toType t) - toDec a@(Hs.DataDecl _ dOrN cxt h qcds qns) + toDec a@(Exts.DataDecl _ dOrN cxt h qcds qns) = case dOrN of - Hs.DataType _ -> DataD (toCxt cxt) + Exts.DataType _ -> TH.DataD (toCxt cxt) (toName h) (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0) @@ -473,11 +558,11 @@ #endif (fmap qualConDeclToCon qcds) (toDerivClauses qns) - Hs.NewType _ -> let qcd = case qcds of + Exts.NewType _ -> let qcd = case qcds of [x] -> x _ -> nonsense "toDec" ("newtype with " ++ "wrong number of constructors") a - in NewtypeD (toCxt cxt) + in TH.NewtypeD (toCxt cxt) (toName h) (toTyVars h) #if MIN_VERSION_template_haskell(2,11,0) @@ -488,253 +573,267 @@ -- This type-signature conversion is just wrong. -- Type variables need to be dealt with. /Jonas - toDec a@(Hs.TypeSig _ ns t) + toDec _a@(Exts.TypeSig _ ns t) -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class! - = let xs = fmap (flip SigD (toType t) . toName) ns + = let xs = fmap (flip TH.SigD (toType t) . toName) ns in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!" - toDec (Hs.InlineConlikeSig _ act qn) = PragmaD $ - InlineP (toName qn) Inline ConLike (transAct act) - toDec (Hs.InlineSig _ b act qn) = PragmaD $ - InlineP (toName qn) inline FunLike (transAct act) + 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 = Inline | otherwise = NoInline + inline | b = TH.Inline | otherwise = TH.NoInline #if MIN_VERSION_template_haskell(2,11,0) - toDec (Hs.TypeFamDecl _ h sig inj) - = OpenTypeFamilyD $ TypeFamilyHead (toName h) + toDec (Exts.TypeFamDecl _ h sig inj) + = TH.OpenTypeFamilyD $ TH.TypeFamilyHead (toName h) (toTyVars h) - (maybe NoSig KindSig . toMaybeKind $ sig) + (maybe TH.NoSig TH.KindSig . toMaybeKind $ sig) (fmap toInjectivityAnn inj) - toDec (Hs.DataFamDecl _ _ h sig) - = DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig) -#elif MIN_VERSION_haskell_src_exts(1,18,0) - toDec (Hs.TypeFamDecl _ h sig inj) - = FamilyD TypeFam (toName h) (toTyVars h) (toMaybeKind sig) - toDec (Hs.DataFamDecl _ _ h sig) - = FamilyD DataFam (toName h) (toTyVars h) (toMaybeKind sig) + toDec (Exts.DataFamDecl _ _ h sig) + = TH.DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig) #else - toDec (Hs.TypeFamDecl _ h k) - = FamilyD TypeFam (toName h) (toTyVars h) (fmap toKind k) - - -- TODO: do something with context? - toDec (Hs.DataFamDecl _ _ h k) - = FamilyD DataFam (toName h) (toTyVars h) (fmap toKind k) + toDec (Exts.TypeFamDecl _ h sig inj) + = TH.FamilyD TH.TypeFam (toName h) (toTyVars h) (toMaybeKind sig) + toDec (Exts.DataFamDecl _ _ h sig) + = TH.FamilyD TH.DataFam (toName h) (toTyVars h) (toMaybeKind sig) #endif - toDec a@(Hs.FunBind _ mtchs) = hsMatchesToFunD mtchs - toDec (Hs.PatBind _ p rhs bnds) = ValD (toPat p) + toDec _a@(Exts.FunBind _ mtchs) = hsMatchesToFunD mtchs + toDec (Exts.PatBind _ p rhs bnds) = TH.ValD (toPat p) (hsRhsToBody rhs) (toDecs bnds) - toDec i@(Hs.InstDecl _ (Just overlap) _ _) = + 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. #if MIN_VERSION_template_haskell(2,11,0) - toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD + toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD Nothing (toCxt irule) (toType irule) (toDecs ids) #else - toDec (Hs.InstDecl _ Nothing irule ids) = InstanceD + toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD (toCxt irule) (toType irule) (toDecs ids) #endif - toDec (Hs.ClassDecl _ cxt h fds decls) = ClassD + toDec (Exts.ClassDecl _ cxt h fds decls) = TH.ClassD (toCxt cxt) (toName h) (toTyVars h) (fmap toFunDep fds) (toDecs decls) where - toFunDep (Hs.FunDep _ ls rs) = FunDep (fmap toName ls) (fmap toName rs) + toFunDep (Exts.FunDep _ ls rs) = TH.FunDep (fmap toName ls) (fmap toName rs) toDec x = todo "toDec" x -#if MIN_VERSION_haskell_src_exts(1,18,0) -instance ToMaybeKind (Hs.ResultSig l) where - toMaybeKind (Hs.KindSig _ k) = Just $ toKind k - toMaybeKind (Hs.TyVarSig _ _) = Nothing +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 Nothing = Nothing toMaybeKind (Just a) = toMaybeKind a -#endif #if MIN_VERSION_template_haskell(2,11,0) -instance ToInjectivityAnn (Hs.InjectivityInfo l) where - toInjectivityAnn (Hs.InjectivityInfo _ n ns) = InjectivityAnn (toName n) (fmap toName ns) +instance ToInjectivityAnn (Exts.InjectivityInfo l) where + toInjectivityAnn (Exts.InjectivityInfo _ n ns) = TH.InjectivityAnn (toName n) (fmap toName ns) #endif -transAct :: Maybe (Hs.Activation l) -> Phases -transAct Nothing = AllPhases -transAct (Just (Hs.ActiveFrom _ n)) = FromPhase n -transAct (Just (Hs.ActiveUntil _ n)) = BeforePhase n +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 (Hs.DeclHead l) where - toName (Hs.DHead _ n) = toName n - toName (Hs.DHInfix _ _ n) = toName n - toName (Hs.DHParen _ h) = toName h - toName (Hs.DHApp _ h _) = toName h +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 (Hs.DeclHead l) where - toTyVars (Hs.DHead _ _) = [] - toTyVars (Hs.DHParen _ h) = toTyVars h - toTyVars (Hs.DHInfix _ tvb _) = [toTyVar tvb] - toTyVars (Hs.DHApp _ h tvb) = toTyVars h ++ [toTyVar tvb] +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 Nothing = [] toNames (Just a) = toNames a -instance ToNames (Hs.Deriving l) where +instance ToNames (Exts.Deriving l) where #if MIN_VERSION_haskell_src_exts(1,20,0) - toNames (Hs.Deriving _ _ irules) = + toNames (Exts.Deriving _ _ irules) = concatMap toNames irules #else - toNames (Hs.Deriving _ irules) = + toNames (Exts.Deriving _ irules) = concatMap toNames irules #endif - concatMap toNames irules -instance ToNames (Hs.InstRule l) where - toNames (Hs.IParen _ irule) = toNames irule - toNames (Hs.IRule _ _mtvbs _mcxt mihd) = toNames mihd -instance ToNames (Hs.InstHead l) where - toNames (Hs.IHCon _ n) = [toName n] - toNames (Hs.IHInfix _ _ n) = [toName n] - toNames (Hs.IHParen _ h) = toNames h - toNames (Hs.IHApp _ h _) = toNames h -instance ToCxt (Hs.InstRule l) where - toCxt (Hs.IRule _ _ cxt _) = toCxt cxt - toCxt (Hs.IParen _ irule) = toCxt irule +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 (Hs.Context l) where +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 - Hs.CxEmpty _ -> [] - Hs.CxSingle _ x' -> [toPred x'] - Hs.CxTuple _ xs -> fmap toPred xs + Exts.CxEmpty _ -> [] + Exts.CxSingle _ x' -> [toPred x'] + Exts.CxTuple _ xs -> fmap toPred xs instance ToCxt a => ToCxt (Maybe a) where - toCxt Nothing = [] + toCxt Nothing = [] toCxt (Just a) = toCxt a -instance ToType (Hs.InstRule l) where - toType (Hs.IRule _ _ _ h) = toType h - toType (Hs.IParen _ irule) = toType irule +instance ToType (Exts.InstRule l) where + toType (Exts.IRule _ _ _ h) = toType h + toType (Exts.IParen _ irule) = toType irule -instance ToType (Hs.InstHead l) where - toType (Hs.IHCon _ qn) = toType qn - toType (Hs.IHInfix _ typ qn) = AppT (toType typ) (toType qn) - toType (Hs.IHParen _ hd) = toType hd - toType (Hs.IHApp _ hd typ) = AppT (toType hd) (toType typ) +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 :: Hs.QualConDecl l -> Con -qualConDeclToCon (Hs.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl -qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (toTyVars ns) +qualConDeclToCon :: Exts.QualConDecl l -> TH.Con +qualConDeclToCon (Exts.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl +qualConDeclToCon (Exts.QualConDecl _ ns cxt cdecl) = TH.ForallC (toTyVars ns) (toCxt cxt) (conDeclToCon cdecl) instance ToTyVars a => ToTyVars (Maybe a) where - toTyVars Nothing = [] + toTyVars Nothing = [] toTyVars (Just a) = toTyVars a instance ToTyVars a => ToTyVars [a] where toTyVars = concatMap toTyVars -instance ToTyVars (Hs.TyVarBind l) where +instance ToTyVars (Exts.TyVarBind l) where toTyVars tvb = [toTyVar tvb] -instance ToType (Hs.QName l) where - toType = ConT . toName +instance ToType (Exts.QName l) where + toType = TH.ConT . toName -conDeclToCon :: Hs.ConDecl l -> Con -conDeclToCon (Hs.ConDecl _ n tys) - = NormalC (toName n) (map toStrictType tys) -conDeclToCon (Hs.RecDecl _ n fieldDecls) - = RecC (toName n) (concatMap convField fieldDecls) +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 :: Hs.FieldDecl l -> [VarStrictType] - convField (Hs.FieldDecl _ ns t) = + 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 :: [Hs.Match l] -> Dec -hsMatchesToFunD [] = FunD (mkName []) [] -- errorish -hsMatchesToFunD xs@(Hs.Match _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs) -hsMatchesToFunD xs@(Hs.InfixMatch _ _ n _ _ _ : _) = FunD (toName n) (fmap hsMatchToClause xs) +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 :: Hs.Match l -> Clause -hsMatchToClause (Hs.Match _ _ ps rhs bnds) = Clause +hsMatchToClause :: Exts.Match l -> TH.Clause +hsMatchToClause (Exts.Match _ _ ps rhs bnds) = TH.Clause (fmap toPat ps) (hsRhsToBody rhs) (toDecs bnds) -hsMatchToClause (Hs.InfixMatch _ p _ ps rhs bnds) = Clause +hsMatchToClause (Exts.InfixMatch _ p _ ps rhs bnds) = TH.Clause (fmap toPat (p:ps)) (hsRhsToBody rhs) (toDecs bnds) -hsRhsToBody :: Hs.Rhs l -> Body -hsRhsToBody (Hs.UnGuardedRhs _ e) = NormalB (toExp e) -hsRhsToBody (Hs.GuardedRhss _ hsgrhs) = let fromGuardedB (GuardedB a) = a - in GuardedB . concat - . fmap (fromGuardedB . hsGuardedRhsToBody) - $ hsgrhs - +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 :: Hs.GuardedRhs l -> 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') +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 :: Hs.Stmt l -> Guard -hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)] -hsStmtToGuard (Hs.Qualifier _ e) = NormalG (toExp e) -hsStmtToGuard (Hs.LetStmt _ bs) = PatG [LetS (toDecs bs)] +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 (Hs.InstDecl l) where - toDecs (Hs.InsDecl _ decl) = toDecs decl - toDecs d = todo "toDec" d +instance ToDecs (Exts.InstDecl l) where + toDecs (Exts.InsDecl _ decl) = toDecs decl + toDecs d = todo "toDec" d -- * ToDecs HsDecl HsBinds -instance ToDecs (Hs.Decl l) where - toDecs a@(Hs.TypeSig _ ns t) - = let xs = fmap (flip SigD (toType t) . toName) ns +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 (Hs.InfixDecl l assoc Nothing ops) = - toDecs (Hs.InfixDecl l assoc (Just 9) ops) - toDecs (Hs.InfixDecl _ assoc (Just fixity) ops) = - map (\op -> InfixD (Fixity fixity dir) (toName op)) ops + toDecs (Exts.InfixDecl l assoc Nothing ops) = + toDecs (Exts.InfixDecl l assoc (Just 9) ops) + toDecs (Exts.InfixDecl _ assoc (Just fixity) ops) = + map (\op -> TH.InfixD (TH.Fixity fixity dir) (toName op)) ops where dir = case assoc of - Hs.AssocNone _ -> InfixN - Hs.AssocLeft _ -> InfixL - Hs.AssocRight _ -> InfixR + 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/Utils.hs b/src/Language/Haskell/Meta/Utils.hs --- a/src/Language/Haskell/Meta/Utils.hs +++ b/src/Language/Haskell/Meta/Utils.hs @@ -1,25 +1,29 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving, - DeriveDataTypeable, PatternGuards, FlexibleContexts, FlexibleInstances, - TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} -- | This module is a staging ground -- for to-be-organized-and-merged-nicely code. module Language.Haskell.Meta.Utils where -import Data.List (findIndex) -import Data.Typeable -import Data.Generics hiding(Fixity) +import Control.Monad +import Data.Generics hiding (Fixity) +import Data.List (findIndex) +import Language.Haskell.Exts.Pretty (prettyPrint) 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.Lib hiding (cxt) import Language.Haskell.TH.Ppr +import Language.Haskell.TH.Syntax +import System.IO.Unsafe (unsafePerformIO) import Text.PrettyPrint -import Control.Monad ----------------------------------------------------------------------------- @@ -32,7 +36,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 @@ -41,7 +45,7 @@ -- but useful in general. pretty :: (Show a) => a -> String pretty a = case parseHsExp (show a) of - Left _ -> [] + Left _ -> [] Right e -> prettyPrint e @@ -81,16 +85,16 @@ 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` ("><.\\/!@#$%^&*-+?:|" :: [Char])) @@ -114,7 +118,7 @@ unForall :: Type -> Type unForall (ForallT _ _ t) = t -unForall t = t +unForall t = t functionT :: [TypeQ] -> TypeQ functionT = foldl1 (|->|) @@ -130,6 +134,8 @@ 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 @@ -146,7 +152,7 @@ -- the fresh names list, and add this translation to the returned list. -- The fresh names list should be infinite; myNames is a good example. renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name]) -renameT env [] _ = error "renameT: ran out of names!" +renameT _env [] _ = error "renameT: ran out of names!" renameT env (x:new) (VarT n) | Just n' <- lookup n env = (VarT n',env,x:new) | otherwise = (VarT x, (n,x):env, new) @@ -165,8 +171,8 @@ in (ForallT ns'' cxt' t', env4, new4) where unVarT (VarT n) = PlainTV n + unVarT ty = error $ "renameT: unVarT: TODO for" ++ show ty renamePreds = renameThings renamePred - #if MIN_VERSION_template_haskell(2,10,0) renamePred = renameT #else @@ -179,6 +185,7 @@ (t2', env2, new2) = renameT env1 new1 t2 in (EqualP t1' t2', env2, new2) #endif +renameT _ _ t = error $ "renameT: TODO for " ++ show t -- | Remove qualification, etc. normaliseName :: Name -> Name @@ -221,6 +228,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 @@ -230,61 +241,61 @@ decCons :: Dec -> [Con] #if MIN_VERSION_template_haskell(2,11,0) -decCons (DataD _ _ _ _ cons _) = cons +decCons (DataD _ _ _ _ cons _) = cons decCons (NewtypeD _ _ _ _ con _) = [con] #else -decCons (DataD _ _ _ cons _) = cons -decCons (NewtypeD _ _ _ con _) = [con] +decCons (DataD _ _ _ cons _) = cons +decCons (NewtypeD _ _ _ con _) = [con] #endif -decCons _ = [] +decCons _ = [] decTyVars :: Dec -> [TyVarBndr] #if MIN_VERSION_template_haskell(2,11,0) -decTyVars (DataD _ _ ns _ _ _) = ns +decTyVars (DataD _ _ ns _ _ _) = ns decTyVars (NewtypeD _ _ ns _ _ _) = ns #else -decTyVars (DataD _ _ ns _ _) = ns -decTyVars (NewtypeD _ _ ns _ _) = ns +decTyVars (DataD _ _ ns _ _) = ns +decTyVars (NewtypeD _ _ ns _ _) = ns #endif -decTyVars (TySynD _ ns _) = ns -decTyVars (ClassD _ _ ns _ _) = ns -decTyVars _ = [] +decTyVars (TySynD _ ns _) = ns +decTyVars (ClassD _ _ ns _ _) = ns +decTyVars _ = [] decName :: Dec -> Maybe Name -decName (FunD n _) = Just n +decName (FunD n _) = Just n #if MIN_VERSION_template_haskell(2,11,0) -decName (DataD _ n _ _ _ _) = Just n +decName (DataD _ n _ _ _ _) = Just n decName (NewtypeD _ n _ _ _ _) = Just n #else -decName (DataD _ n _ _ _) = Just n -decName (NewtypeD _ n _ _ _) = Just n +decName (DataD _ n _ _ _) = Just n +decName (NewtypeD _ n _ _ _) = Just n #endif -decName (TySynD n _ _) = Just n -decName (ClassD _ n _ _ _) = Just n -decName (SigD n _) = Just n -decName (ForeignD fgn) = Just (foreignName fgn) -decName _ = Nothing +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 +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. @@ -308,42 +319,52 @@ -- | 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 +recCName _ = Nothing dataDCons :: Dec -> [Con] #if MIN_VERSION_template_haskell(2,11,0) dataDCons (DataD _ _ _ _ cons _) = cons #else -dataDCons (DataD _ _ _ cons _) = cons +dataDCons (DataD _ _ _ cons _) = cons #endif -dataDCons _ = [] +dataDCons _ = [] fromDataConI :: Info -> Q (Maybe Exp) #if MIN_VERSION_template_haskell(2,11,0) -fromDataConI (DataConI dConN ty tyConN) = +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))) #else -fromDataConI (DataConI dConN ty tyConN fxty) = -#endif +fromDataConI (DataConI dConN ty _tyConN _fxty) = let n = arityT ty in replicateM n (newName "a") >>= \ns -> return (Just (LamE [ConP dConN (fmap VarP ns)] (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) []] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -2,17 +2,22 @@ module Main where -import Language.Haskell.Meta.Parse -import qualified Language.Haskell.Exts as Exts +import qualified Control.Monad.Fail as Fail +import qualified Language.Haskell.Exts as Exts import qualified Language.Haskell.Exts.Extension as Extension -import qualified Language.Haskell.Exts.Parser as Parser -import qualified Language.Haskell.TH as TH -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit (Assertion, (@?=)) +import qualified Language.Haskell.Exts.Parser as Parser +import Language.Haskell.Meta.Parse +import qualified Language.Haskell.TH as TH +-- import Test.Framework +-- import Test.Framework.Providers.HUnit +import Test.HUnit (Assertion, (@?=)) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (testCase) +type Test = TestTree + main :: IO () -main = defaultMain tests +main = defaultMain (testGroup "unit" tests) tests :: [Test] tests = [ derivingClausesTest @@ -44,5 +49,5 @@ declsExts' <- liftEither $ parseDecsWithMode mode s >>= parseHsDeclsWithMode mode . TH.pprint declsExts' @?= declsExts -liftEither :: Monad m => Either String a -> m a +liftEither :: Fail.MonadFail m => Either String a -> m a liftEither = either fail return diff --git a/tests/Splices.hs b/tests/Splices.hs --- a/tests/Splices.hs +++ b/tests/Splices.hs @@ -1,8 +1,15 @@ -{-# LANGUAGE CPP, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE TypeApplications #-} +#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 +import qualified Language.Haskell.Exts.Parser as Parser +import qualified Language.Haskell.Meta as Meta ----- Testing names ----- @@ -53,8 +60,9 @@ -- Just to check that it works as intended +main :: IO () main = do - -9 <- return $(either error return $ Meta.parseExp "-3^2") :: IO Int + -9 <- return $(either error return $ Meta.parseExp "-3^2 :: Int") :: IO Int () <- unit [] <- return (nilp []) (1,2) <- return pair diff --git a/tests/TestExamples.hs b/tests/TestExamples.hs --- a/tests/TestExamples.hs +++ b/tests/TestExamples.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} - -import Control.Monad (when) +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} import qualified BF import qualified Hs import qualified HsHere import qualified SKI -import SKI (SKI(S, K, I, (:$))) +import SKI (SKI ((:$), I, K, S)) -- Very dumb test framework shouldBe :: (Show a, Eq a) => a -> a -> IO () @@ -27,7 +26,7 @@ hereTest :: IO () hereTest = do - a 3 `shouldBe` (" random \"text\" "++ show (3 + 1) ++"\n something else") + a 3 `shouldBe` (" random \"text\" "++ show (3 + 1 :: Int) ++"\n something else") -- TODO: better test exercising the bf quasiquoter @@ -37,7 +36,7 @@ hsTest :: IO () hsTest = do - (\ [Hs.hs|a@(x,_)|] -> [Hs.hs|(a,x)|]) (42,88) `shouldBe` ((42,88),42) + (\ [Hs.hs|b@(x,_)|] -> [Hs.hs|(b,x)|]) (42 :: Int,88 :: Int) `shouldBe` ((42,88),42) -- TODO: better test exercising the ski quasiquoter