{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeSynonymInstances #-}

{- |
  Module      :  Language.Haskell.Meta.Syntax.Translate
  Copyright   :  (c) Matt Morrow 2008
  License     :  BSD3
  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
  Stability   :  experimental
  Portability :  portable (template-haskell)
-}

module Language.Haskell.Meta.Syntax.Translate (
    module Language.Haskell.Meta.Syntax.Translate
  , TyVarBndr_
) where

import qualified Data.Char                      as Char
import qualified Data.List                      as List
import qualified Language.Haskell.Exts.SrcLoc   as Exts.SrcLoc
import qualified Language.Haskell.Exts.Syntax   as Exts
import           Language.Haskell.Meta.THCompat (TyVarBndr_)
import qualified Language.Haskell.Meta.THCompat as Compat
import qualified Language.Haskell.TH.Lib        as TH
import qualified Language.Haskell.TH.Syntax     as TH

-----------------------------------------------------------------------------

class ToName a where toName :: a -> TH.Name
class ToNames a where toNames :: a -> [TH.Name]
class ToLit  a where toLit  :: a -> TH.Lit
class ToType a where toType :: a -> TH.Type
class ToPat  a where toPat  :: a -> TH.Pat
class ToExp  a where toExp  :: a -> TH.Exp
class ToDecs a where toDecs :: a -> [TH.Dec]
class ToDec  a where toDec  :: a -> TH.Dec
class ToStmt a where toStmt :: a -> TH.Stmt
class ToLoc  a where toLoc  :: a -> TH.Loc
class ToCxt  a where toCxt  :: a -> TH.Cxt
class ToPred a where toPred :: a -> TH.Pred
class ToTyVars a where toTyVars :: a -> [TyVarBndr_ ()]
class ToMaybeKind a where toMaybeKind :: a -> Maybe TH.Kind
class ToInjectivityAnn a where toInjectivityAnn :: a -> TH.InjectivityAnn

type DerivClause = TH.DerivClause

class ToDerivClauses a where toDerivClauses :: a -> [DerivClause]

-- for error messages
moduleName :: String
moduleName :: String
moduleName = String
"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 :: String -> f e -> a
noTH String
fun f e
thing = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> ([String] -> String) -> [String] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> a) -> [String] -> a
forall a b. (a -> b) -> a -> b
$ [String
moduleName, String
".", String
fun,
  String
": template-haskell has no representation for: ", f () -> String
forall a. Show a => a -> String
show ((e -> ()) -> f e -> f ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> e -> ()
forall a b. a -> b -> a
const ()) f e
thing)]

noTHyet :: (Functor f, Show (f ())) => String -> String -> f e -> a
noTHyet :: String -> String -> f e -> a
noTHyet String
fun String
minVersion f e
thing = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> ([String] -> String) -> [String] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> a) -> [String] -> a
forall a b. (a -> b) -> a -> b
$ [String
moduleName, String
".", String
fun,
  String
": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")",
  String
" has no representation for: ", f () -> String
forall a. Show a => a -> String
show ((e -> ()) -> f e -> f ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> e -> ()
forall a b. a -> b -> a
const ()) f e
thing)]

todo :: (Functor f, Show (f ())) => String -> f e -> a
todo :: String -> f e -> a
todo String
fun f e
thing = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> ([String] -> String) -> [String] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> a) -> [String] -> a
forall a b. (a -> b) -> a -> b
$ [String
moduleName, String
".", String
fun,
  String
": not implemented: ", f () -> String
forall a. Show a => a -> String
show ((e -> ()) -> f e -> f ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> e -> ()
forall a b. a -> b -> a
const ()) f e
thing)]

nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a
nonsense :: String -> String -> f e -> a
nonsense String
fun String
inparticular f e
thing = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> ([String] -> String) -> [String] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> a) -> [String] -> a
forall a b. (a -> b) -> a -> b
$ [String
moduleName, String
".", String
fun,
  String
": nonsensical: ", String
inparticular, String
": ", f () -> String
forall a. Show a => a -> String
show ((e -> ()) -> f e -> f ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> e -> ()
forall a b. a -> b -> a
const ()) f e
thing)]

#if MIN_VERSION_template_haskell(2,16,0)
toTupEl :: ToExp a => a -> Maybe TH.Exp
toTupEl :: a -> Maybe Exp
toTupEl = Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (a -> Exp) -> a -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Exp
forall a. ToExp a => a -> Exp
toExp
#else
toTupEl :: ToExp a => a -> TH.Exp
toTupEl = toExp
#endif

-----------------------------------------------------------------------------


instance ToExp TH.Lit where
  toExp :: Lit -> Exp
toExp = Lit -> Exp
TH.LitE
instance (ToExp a) => ToExp [a] where
  toExp :: [a] -> Exp
toExp = [Exp] -> Exp
TH.ListE ([Exp] -> Exp) -> ([a] -> [Exp]) -> [a] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Exp) -> [a] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Exp
forall a. ToExp a => a -> Exp
toExp
instance (ToExp a, ToExp b) => ToExp (a,b) where
  toExp :: (a, b) -> Exp
toExp (a
a,b
b) = [Maybe Exp] -> Exp
TH.TupE [a -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl a
a, b -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl b
b]
instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where
  toExp :: (a, b, c) -> Exp
toExp (a
a,b
b,c
c) = [Maybe Exp] -> Exp
TH.TupE [a -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl a
a, b -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl b
b, c -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl c
c]
instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where
  toExp :: (a, b, c, d) -> Exp
toExp (a
a,b
b,c
c,d
d) = [Maybe Exp] -> Exp
TH.TupE [a -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl a
a, b -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl b
b, c -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl c
c, d -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl d
d]


instance ToPat TH.Lit where
  toPat :: Lit -> Pat
toPat = Lit -> Pat
TH.LitP
instance (ToPat a) => ToPat [a] where
  toPat :: [a] -> Pat
toPat = [Pat] -> Pat
TH.ListP ([Pat] -> Pat) -> ([a] -> [Pat]) -> [a] -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Pat) -> [a] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Pat
forall a. ToPat a => a -> Pat
toPat
instance (ToPat a, ToPat b) => ToPat (a,b) where
  toPat :: (a, b) -> Pat
toPat (a
a,b
b) = [Pat] -> Pat
TH.TupP [a -> Pat
forall a. ToPat a => a -> Pat
toPat a
a, b -> Pat
forall a. ToPat a => a -> Pat
toPat b
b]
instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where
  toPat :: (a, b, c) -> Pat
toPat (a
a,b
b,c
c) = [Pat] -> Pat
TH.TupP [a -> Pat
forall a. ToPat a => a -> Pat
toPat a
a, b -> Pat
forall a. ToPat a => a -> Pat
toPat b
b, c -> Pat
forall a. ToPat a => a -> Pat
toPat c
c]
instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where
  toPat :: (a, b, c, d) -> Pat
toPat (a
a,b
b,c
c,d
d) = [Pat] -> Pat
TH.TupP [a -> Pat
forall a. ToPat a => a -> Pat
toPat a
a, b -> Pat
forall a. ToPat a => a -> Pat
toPat b
b, c -> Pat
forall a. ToPat a => a -> Pat
toPat c
c, d -> Pat
forall a. ToPat a => a -> Pat
toPat d
d]


instance ToLit Char where
  toLit :: Char -> Lit
toLit = Char -> Lit
TH.CharL
instance ToLit String where
  toLit :: String -> Lit
toLit = String -> Lit
TH.StringL
instance ToLit Integer where
  toLit :: Integer -> Lit
toLit = Integer -> Lit
TH.IntegerL
instance ToLit Int where
  toLit :: Int -> Lit
toLit = Integer -> Lit
TH.IntegerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger
instance ToLit Float where
  toLit :: Float -> Lit
toLit = Rational -> Lit
TH.RationalL (Rational -> Lit) -> (Float -> Rational) -> Float -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Rational
forall a. Real a => a -> Rational
toRational
instance ToLit Double where
  toLit :: Double -> Lit
toLit = Rational -> Lit
TH.RationalL (Rational -> Lit) -> (Double -> Rational) -> Double -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
forall a. Real a => a -> Rational
toRational


-----------------------------------------------------------------------------


-- * ToName {String,HsName,Module,HsSpecialCon,HsQName}


instance ToName String where
  toName :: String -> Name
toName = String -> Name
TH.mkName

instance ToName (Exts.Name l) where
  toName :: Name l -> Name
toName (Exts.Ident l
_ String
s)  = String -> Name
forall a. ToName a => a -> Name
toName String
s
  toName (Exts.Symbol l
_ String
s) = String -> Name
forall a. ToName a => a -> Name
toName String
s

instance ToName (Exts.SpecialCon l) where
  toName :: SpecialCon l -> Name
toName (Exts.UnitCon l
_) = String -> Name
TH.mkName String
"()" -- TODO LumiGuide: '()
  toName (Exts.ListCon l
_) = ''[] -- Parser only uses this in types -- TODO LumiGuide: '[]
  toName (Exts.FunCon l
_)  = ''(->)
  toName (Exts.TupleCon l
_ Boxed
_ Int
n) =
    String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(",Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',',String
")"]
    -- TODO LumiGuide:
    -- .
    -- .| n<2 = '()
    -- .| otherwise =
    -- .  let x = maybe [] (++".") (nameModule '(,))
    -- .  in TH.mkName . concat $ x : ["(",replicate (n-1) ',',")"]
  toName (Exts.Cons l
_)    = '(:)
  toName SpecialCon l
h = String -> SpecialCon l -> Name
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"toName not implemented" SpecialCon l
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 :: QName l -> Name
toName (Exts.Qual l
_ (Exts.ModuleName l
_ []) Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.Qual l
_ (Exts.ModuleName l
_ String
m) Name l
n) =
    let m' :: String
m' = Name -> String
forall a. Show a => a -> String
show (Name -> String) -> (String -> Name) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
forall a. ToName a => a -> Name
toName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
m
        n' :: String
n' = Name -> String
forall a. Show a => a -> String
show (Name -> String) -> (Name l -> Name) -> Name l -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name l -> Name
forall a. ToName a => a -> Name
toName (Name l -> String) -> Name l -> String
forall a b. (a -> b) -> a -> b
$ Name l
n
    in String -> Name
forall a. ToName a => a -> Name
toName (String -> Name) -> ([String] -> String) -> [String] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> Name) -> [String] -> Name
forall a b. (a -> b) -> a -> b
$ [String
m',String
".",String
n']
  toName (Exts.UnQual l
_ Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.Special l
_ SpecialCon l
s) = SpecialCon l -> Name
forall a. ToName a => a -> Name
toName SpecialCon l
s

#if MIN_VERSION_haskell_src_exts(1,20,1)
instance ToName (Exts.MaybePromotedName l) where
  toName :: MaybePromotedName l -> Name
toName (Exts.PromotedName   l
_ QName l
qn) = QName l -> Name
forall a. ToName a => a -> Name
toName QName l
qn
  toName (Exts.UnpromotedName l
_ QName l
qn) = QName l -> Name
forall a. ToName a => a -> Name
toName QName l
qn
#endif

instance ToName (Exts.Op l) where
  toName :: Op l -> Name
toName (Exts.VarOp l
_ Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.ConOp l
_ Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n


-----------------------------------------------------------------------------

-- * ToLit HsLiteral


instance ToLit (Exts.Literal l) where
  toLit :: Literal l -> Lit
toLit (Exts.Char l
_ Char
a String
_) = Char -> Lit
TH.CharL Char
a
  toLit (Exts.String l
_ String
a String
_) = String -> Lit
TH.StringL String
a
  toLit (Exts.Int l
_ Integer
a String
_) = Integer -> Lit
TH.IntegerL Integer
a
  toLit (Exts.Frac l
_ Rational
a String
_) = Rational -> Lit
TH.RationalL Rational
a
  toLit l :: Literal l
l@Exts.PrimChar{} = String -> Literal l -> Lit
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toLit" Literal l
l
  toLit (Exts.PrimString l
_ String
a String
_) = [Word8] -> Lit
TH.StringPrimL ((Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
toWord8 String
a)
   where
    toWord8 :: Char -> Word8
toWord8 = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
Char.ord
  toLit (Exts.PrimInt l
_ Integer
a String
_) = Integer -> Lit
TH.IntPrimL Integer
a
  toLit (Exts.PrimFloat l
_ Rational
a String
_) = Rational -> Lit
TH.FloatPrimL Rational
a
  toLit (Exts.PrimDouble l
_ Rational
a String
_) = Rational -> Lit
TH.DoublePrimL Rational
a
  toLit (Exts.PrimWord l
_ Integer
a String
_) = Integer -> Lit
TH.WordPrimL Integer
a


-----------------------------------------------------------------------------

-- * ToPat HsPat

instance ToPat (Exts.Pat l) where
  toPat :: Pat l -> Pat
toPat (Exts.PVar l
_ Name l
n)
    = Name -> Pat
TH.VarP (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n)
  toPat (Exts.PLit l
_ (Exts.Signless l
_) Literal l
l)
    = Lit -> Pat
TH.LitP (Literal l -> Lit
forall a. ToLit a => a -> Lit
toLit Literal l
l)
  toPat (Exts.PLit l
_ (Exts.Negative l
_) Literal l
l) = Lit -> Pat
TH.LitP (Lit -> Pat) -> Lit -> Pat
forall a b. (a -> b) -> a -> b
$ case Literal l -> Lit
forall a. ToLit a => a -> Lit
toLit Literal l
l of
    TH.IntegerL Integer
z      -> Integer -> Lit
TH.IntegerL (Integer -> Integer
forall a. Num a => a -> a
negate Integer
z)
    TH.RationalL Rational
q     -> Rational -> Lit
TH.RationalL (Rational -> Rational
forall a. Num a => a -> a
negate Rational
q)
    TH.IntPrimL Integer
z'     -> Integer -> Lit
TH.IntPrimL (Integer -> Integer
forall a. Num a => a -> a
negate Integer
z')
    TH.FloatPrimL Rational
r'   -> Rational -> Lit
TH.FloatPrimL (Rational -> Rational
forall a. Num a => a -> a
negate Rational
r')
    TH.DoublePrimL Rational
r'' -> Rational -> Lit
TH.DoublePrimL (Rational -> Rational
forall a. Num a => a -> a
negate Rational
r'')
    Lit
_                  -> String -> String -> Literal l -> Lit
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> String -> f e -> a
nonsense String
"toPat" String
"negating wrong kind of literal" Literal l
l
  toPat (Exts.PInfixApp l
_ Pat l
p QName l
n Pat l
q) = Pat -> Name -> Pat -> Pat
TH.UInfixP (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p) (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n) (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
q)
  toPat (Exts.PApp l
_ QName l
n [Pat l]
ps) = Name -> [Pat] -> Pat
Compat.conP (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n) ((Pat l -> Pat) -> [Pat l] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
  toPat (Exts.PTuple l
_ Boxed
Exts.Boxed [Pat l]
ps) = [Pat] -> Pat
TH.TupP ((Pat l -> Pat) -> [Pat l] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
  toPat (Exts.PTuple l
_ Boxed
Exts.Unboxed [Pat l]
ps) = [Pat] -> Pat
TH.UnboxedTupP ((Pat l -> Pat) -> [Pat l] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
  toPat (Exts.PList l
_ [Pat l]
ps) = [Pat] -> Pat
TH.ListP ((Pat l -> Pat) -> [Pat l] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
  toPat (Exts.PParen l
_ Pat l
p) = Pat -> Pat
TH.ParensP (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p)
  -- TODO: move toFieldPat to top level defn
  toPat (Exts.PRec l
_ QName l
n [PatField l]
pfs) = let toFieldPat :: PatField e -> (Name, Pat)
toFieldPat (Exts.PFieldPat e
_ QName e
n' Pat e
p) = (QName e -> Name
forall a. ToName a => a -> Name
toName QName e
n', Pat e -> Pat
forall a. ToPat a => a -> Pat
toPat Pat e
p)
                                  toFieldPat PatField e
h = String -> PatField e -> (Name, Pat)
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"toFieldPat" PatField e
h
                            in Name -> [(Name, Pat)] -> Pat
TH.RecP (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n) ((PatField l -> (Name, Pat)) -> [PatField l] -> [(Name, Pat)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatField l -> (Name, Pat)
forall e. PatField e -> (Name, Pat)
toFieldPat [PatField l]
pfs)
  toPat (Exts.PAsPat l
_ Name l
n Pat l
p) = Name -> Pat -> Pat
TH.AsP (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n) (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p)
  toPat (Exts.PWildCard l
_) = Pat
TH.WildP
  toPat (Exts.PIrrPat l
_ Pat l
p) = Pat -> Pat
TH.TildeP (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p)
  toPat (Exts.PatTypeSig l
_ Pat l
p Type l
t) = Pat -> Type -> Pat
TH.SigP (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t)
  toPat (Exts.PViewPat l
_ Exp l
e Pat l
p) = Exp -> Pat -> Pat
TH.ViewP (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p)
  -- regular pattern
  toPat p :: Pat l
p@Exts.PRPat{} = String -> Pat l -> Pat
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toPat" Pat l
p
  -- XML stuff
  toPat p :: Pat l
p@Exts.PXTag{} = String -> Pat l -> Pat
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toPat" Pat l
p
  toPat p :: Pat l
p@Exts.PXETag{} = String -> Pat l -> Pat
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toPat" Pat l
p
  toPat p :: Pat l
p@Exts.PXPcdata{} = String -> Pat l -> Pat
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toPat" Pat l
p
  toPat p :: Pat l
p@Exts.PXPatTag{} = String -> Pat l -> Pat
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toPat" Pat l
p
  toPat (Exts.PBangPat l
_ Pat l
p) = Pat -> Pat
TH.BangP (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p)
  toPat Pat l
p = String -> Pat l -> Pat
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"toPat" Pat l
p
  -- TODO
            -- (Exts.PNPlusK _ _ _)
            -- (Exts.PUnboxedSum _ _ _ _)
            -- (Exts.PXRPats _ _)
            -- (Exts.PSplice _ _)
            -- ...

-----------------------------------------------------------------------------

-- * ToExp HsExp

instance ToExp (Exts.QOp l) where
  toExp :: QOp l -> Exp
toExp (Exts.QVarOp l
_ QName l
n) = Name -> Exp
TH.VarE (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n)
  toExp (Exts.QConOp l
_ QName l
n) = Name -> Exp
TH.ConE (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n)

toFieldExp :: Exts.FieldUpdate l -> TH.FieldExp
toFieldExp :: FieldUpdate l -> FieldExp
toFieldExp (Exts.FieldUpdate l
_ QName l
n Exp l
e) = (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n, Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
toFieldExp FieldUpdate l
h                        = String -> FieldUpdate l -> FieldExp
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"toFieldExp" FieldUpdate l
h




instance ToExp (Exts.Exp l) where
  toExp :: Exp l -> Exp
toExp (Exts.Var l
_ QName l
n)                 = Name -> Exp
TH.VarE (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n)
  toExp e :: Exp l
e@Exts.IPVar{}                 = String -> Exp l -> Exp
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toExp" Exp l
e
  toExp (Exts.Con l
_ QName l
n)                 = Name -> Exp
TH.ConE (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n)
  toExp (Exts.Lit l
_ Literal l
l)                 = Lit -> Exp
TH.LitE (Literal l -> Lit
forall a. ToLit a => a -> Lit
toLit Literal l
l)
#if MIN_VERSION_template_haskell(2,13,0)
  toExp (Exts.OverloadedLabel l
_ String
s)     = String -> Exp
TH.LabelE String
s
#endif
  toExp (Exts.InfixApp l
_ Exp l
e QOp l
o Exp l
f)        = Exp -> Exp -> Exp -> Exp
TH.UInfixE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (QOp l -> Exp
forall a. ToExp a => a -> Exp
toExp QOp l
o) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
f)
  toExp (Exts.App l
_ Exp l
e (Exts.TypeApp l
_ Type l
t)) = Exp -> Type -> Exp
TH.AppTypeE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t)
  toExp (Exts.App l
_ Exp l
e Exp l
f)               = Exp -> Exp -> Exp
TH.AppE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
f)
  toExp (Exts.NegApp l
_ Exp l
e)              = Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'negate) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toExp (Exts.Lambda l
_ [Pat l]
ps Exp l
e)           = [Pat] -> Exp -> Exp
TH.LamE ((Pat l -> Pat) -> [Pat l] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat [Pat l]
ps) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toExp (Exts.Let l
_ Binds l
bs Exp l
e)              = [Dec] -> Exp -> Exp
TH.LetE (Binds l -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Binds l
bs) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toExp (Exts.If l
_ Exp l
a Exp l
b Exp l
c)              = Exp -> Exp -> Exp -> Exp
TH.CondE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
a) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
b) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
c)
  toExp (Exts.MultiIf l
_ [GuardedRhs l]
ifs)           = [(Guard, Exp)] -> Exp
TH.MultiIfE ((GuardedRhs l -> (Guard, Exp)) -> [GuardedRhs l] -> [(Guard, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map GuardedRhs l -> (Guard, Exp)
forall l. GuardedRhs l -> (Guard, Exp)
toGuard [GuardedRhs l]
ifs)
  toExp (Exts.Case l
_ Exp l
e [Alt l]
alts)           = Exp -> [Match] -> Exp
TH.CaseE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) ((Alt l -> Match) -> [Alt l] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map Alt l -> Match
forall l. Alt l -> Match
toMatch [Alt l]
alts)
#if MIN_VERSION_template_haskell(2,17,0)
  toExp (Exts.Do _ ss)                 = TH.DoE Nothing (map toStmt ss)
#else
  toExp (Exts.Do l
_ [Stmt l]
ss)                 = [Stmt] -> Exp
TH.DoE ((Stmt l -> Stmt) -> [Stmt l] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map Stmt l -> Stmt
forall a. ToStmt a => a -> Stmt
toStmt [Stmt l]
ss)
#endif
  toExp e :: Exp l
e@Exts.MDo{}                   = String -> Exp l -> Exp
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toExp" Exp l
e
  toExp (Exts.Tuple l
_ Boxed
Exts.Boxed [Exp l]
xs)   = [Maybe Exp] -> Exp
TH.TupE ((Exp l -> Maybe Exp) -> [Exp l] -> [Maybe Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp l -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl [Exp l]
xs)
  toExp (Exts.Tuple l
_ Boxed
Exts.Unboxed [Exp l]
xs) = [Maybe Exp] -> Exp
TH.UnboxedTupE ((Exp l -> Maybe Exp) -> [Exp l] -> [Maybe Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp l -> Maybe Exp
forall a. ToExp a => a -> Maybe Exp
toTupEl [Exp l]
xs)
  toExp e :: Exp l
e@Exts.TupleSection{}          = String -> Exp l -> Exp
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toExp" Exp l
e
  toExp (Exts.List l
_ [Exp l]
xs)               = [Exp] -> Exp
TH.ListE ((Exp l -> Exp) -> [Exp l] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp [Exp l]
xs)
  toExp (Exts.Paren l
_ Exp l
e)               = Exp -> Exp
TH.ParensE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toExp (Exts.LeftSection l
_ Exp l
e QOp l
o)       = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Exp l -> Exp) -> Exp l -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp (Exp l -> Maybe Exp) -> Exp l -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Exp l
e) (QOp l -> Exp
forall a. ToExp a => a -> Exp
toExp QOp l
o) Maybe Exp
forall a. Maybe a
Nothing
  toExp (Exts.RightSection l
_ QOp l
o Exp l
f)      = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE Maybe Exp
forall a. Maybe a
Nothing (QOp l -> Exp
forall a. ToExp a => a -> Exp
toExp QOp l
o) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Exp l -> Exp) -> Exp l -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp (Exp l -> Maybe Exp) -> Exp l -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Exp l
f)
  toExp (Exts.RecConstr l
_ QName l
n [FieldUpdate l]
xs)        = Name -> [FieldExp] -> Exp
TH.RecConE (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n) ((FieldUpdate l -> FieldExp) -> [FieldUpdate l] -> [FieldExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldUpdate l -> FieldExp
forall l. FieldUpdate l -> FieldExp
toFieldExp [FieldUpdate l]
xs)
  toExp (Exts.RecUpdate l
_ Exp l
e [FieldUpdate l]
xs)        = Exp -> [FieldExp] -> Exp
TH.RecUpdE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) ((FieldUpdate l -> FieldExp) -> [FieldUpdate l] -> [FieldExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldUpdate l -> FieldExp
forall l. FieldUpdate l -> FieldExp
toFieldExp [FieldUpdate l]
xs)
  toExp (Exts.EnumFrom l
_ Exp l
e)            = Range -> Exp
TH.ArithSeqE (Range -> Exp) -> Range -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Range
TH.FromR (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toExp (Exts.EnumFromTo l
_ Exp l
e Exp l
f)        = Range -> Exp
TH.ArithSeqE (Range -> Exp) -> Range -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Range
TH.FromToR (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
f)
  toExp (Exts.EnumFromThen l
_ Exp l
e Exp l
f)      = Range -> Exp
TH.ArithSeqE (Range -> Exp) -> Range -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Range
TH.FromThenR (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
f)
  toExp (Exts.EnumFromThenTo l
_ Exp l
e Exp l
f Exp l
g)  = Range -> Exp
TH.ArithSeqE (Range -> Exp) -> Range -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Range
TH.FromThenToR (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
f) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
g)
  toExp (Exts.ListComp l
_ Exp l
e [QualStmt l]
ss)         = [Stmt] -> Exp
TH.CompE ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ (QualStmt l -> Stmt) -> [QualStmt l] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map QualStmt l -> Stmt
forall e. QualStmt e -> Stmt
convert [QualStmt l]
ss [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Exp -> Stmt
TH.NoBindS (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)]
   where
    convert :: QualStmt e -> Stmt
convert (Exts.QualStmt e
_ Stmt e
st) = Stmt e -> Stmt
forall a. ToStmt a => a -> Stmt
toStmt Stmt e
st
    convert QualStmt e
s                    = String -> QualStmt e -> Stmt
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toExp ListComp" QualStmt e
s
  toExp (Exts.ExpTypeSig l
_ Exp l
e Type l
t)      = Exp -> Type -> Exp
TH.SigE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t)
  toExp Exp l
e = String -> Exp l -> Exp
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"toExp" Exp l
e


toMatch :: Exts.Alt l -> TH.Match
toMatch :: Alt l -> Match
toMatch (Exts.Alt l
_ Pat l
p Rhs l
rhs Maybe (Binds l)
ds) = Pat -> Body -> [Dec] -> Match
TH.Match (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p) (Rhs l -> Body
forall l. Rhs l -> Body
toBody Rhs l
rhs) (Maybe (Binds l) -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Maybe (Binds l)
ds)

toBody :: Exts.Rhs l -> TH.Body
toBody :: Rhs l -> Body
toBody (Exts.UnGuardedRhs l
_ Exp l
e)   = Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e
toBody (Exts.GuardedRhss l
_ [GuardedRhs l]
rhss) = [(Guard, Exp)] -> Body
TH.GuardedB ([(Guard, Exp)] -> Body) -> [(Guard, Exp)] -> Body
forall a b. (a -> b) -> a -> b
$ (GuardedRhs l -> (Guard, Exp)) -> [GuardedRhs l] -> [(Guard, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map GuardedRhs l -> (Guard, Exp)
forall l. GuardedRhs l -> (Guard, Exp)
toGuard [GuardedRhs l]
rhss

toGuard :: Exts.GuardedRhs l -> (TH.Guard, TH.Exp)
toGuard :: GuardedRhs l -> (Guard, Exp)
toGuard (Exts.GuardedRhs l
_ [Stmt l]
stmts Exp l
e) = (Guard
g, Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
  where
    g :: Guard
g = case (Stmt l -> Stmt) -> [Stmt l] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map Stmt l -> Stmt
forall a. ToStmt a => a -> Stmt
toStmt [Stmt l]
stmts of
      [TH.NoBindS Exp
x] -> Exp -> Guard
TH.NormalG Exp
x
      [Stmt]
xs             -> [Stmt] -> Guard
TH.PatG [Stmt]
xs

instance ToDecs a => ToDecs (Maybe a) where
    toDecs :: Maybe a -> [Dec]
toDecs Maybe a
Nothing  = []
    toDecs (Just a
a) = a -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs a
a

instance ToDecs (Exts.Binds l) where
  toDecs :: Binds l -> [Dec]
toDecs (Exts.BDecls l
_ [Decl l]
ds)  = [Decl l] -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs [Decl l]
ds
  toDecs a :: Binds l
a@(Exts.IPBinds {}) = String -> Binds l -> [Dec]
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"ToDecs Exts.Binds" Binds l
a

instance ToDecs (Exts.ClassDecl l) where
  toDecs :: ClassDecl l -> [Dec]
toDecs (Exts.ClsDecl l
_ Decl l
d) = Decl l -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Decl l
d
  toDecs ClassDecl l
x                  = String -> ClassDecl l -> [Dec]
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"classDecl" ClassDecl l
x

-----------------------------------------------------------------------------

-- * ToLoc SrcLoc

instance ToLoc Exts.SrcLoc.SrcLoc where
  toLoc :: SrcLoc -> Loc
toLoc (Exts.SrcLoc.SrcLoc String
fn Int
l Int
c) =
    String -> String -> String -> CharPos -> CharPos -> Loc
TH.Loc String
fn [] [] (Int
l,Int
c) (-Int
1,-Int
1)

-----------------------------------------------------------------------------

-- * ToType HsType

instance ToName (Exts.TyVarBind l) where
  toName :: TyVarBind l -> Name
toName (Exts.KindedVar l
_ Name l
n Kind l
_) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.UnkindedVar l
_ Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n

instance ToName TH.Name where
  toName :: Name -> Name
toName = Name -> Name
forall a. a -> a
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 :: TyVarBndr_ flag -> Name
toName (TH.PlainTV Name
n)      = Name
n
  toName (TH.KindedTV Name
n Type
_)   = Name
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 :: Kind l -> Type
toKind = Kind l -> Type
forall a. ToType a => a -> Type
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 :: TyVarBind l -> TyVarBndr_ flag
toTyVar (Exts.KindedVar l
_ Name l
n Kind l
k) = Name -> Type -> TyVarBndr_ flag
TH.KindedTV (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n) (Kind l -> Type
forall l. Kind l -> Type
toKind Kind l
k)
toTyVar (Exts.UnkindedVar l
_ Name l
n) = Name -> TyVarBndr_ flag
TH.PlainTV (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
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 :: TyVarBndr_ flag -> TyVarBndr_ flag
toTyVarSpec = TyVarBndr_ flag -> TyVarBndr_ flag
forall a. a -> a
id
#endif

instance ToType (Exts.Type l) where
  toType :: Type l -> Type
toType (Exts.TyForall l
_ Maybe [TyVarBind l]
tvbM Maybe (Context l)
cxt Type l
t) = [TyVarBndr_ flag] -> Cxt -> Type -> Type
TH.ForallT ([TyVarBndr_ flag]
-> ([TyVarBind l] -> [TyVarBndr_ flag])
-> Maybe [TyVarBind l]
-> [TyVarBndr_ flag]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((TyVarBind l -> TyVarBndr_ flag)
-> [TyVarBind l] -> [TyVarBndr_ flag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyVarBndr_ flag -> TyVarBndr_ flag
forall flag. TyVarBndr_ flag -> TyVarBndr_ flag
toTyVarSpec (TyVarBndr_ flag -> TyVarBndr_ flag)
-> (TyVarBind l -> TyVarBndr_ flag)
-> TyVarBind l
-> TyVarBndr_ flag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBind l -> TyVarBndr_ flag
forall l. TyVarBind l -> TyVarBndr_ flag
toTyVar)) Maybe [TyVarBind l]
tvbM) (Maybe (Context l) -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t)
  toType (Exts.TyFun l
_ Type l
a Type l
b) = Type l -> Type
forall a. ToType a => a -> Type
toType Type l
a Type -> Type -> Type
.->. Type l -> Type
forall a. ToType a => a -> Type
toType Type l
b
  toType (Exts.TyList l
_ Type l
t) = Type
TH.ListT Type -> Type -> Type
`TH.AppT` Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t
  toType (Exts.TyTuple l
_ Boxed
b [Type l]
ts) = Type -> Cxt -> Type
foldAppT (Int -> Type
tuple (Int -> Type) -> ([Type l] -> Int) -> [Type l] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type l] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Type l] -> Type) -> [Type l] -> Type
forall a b. (a -> b) -> a -> b
$ [Type l]
ts) ((Type l -> Type) -> [Type l] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type l -> Type
forall a. ToType a => a -> Type
toType [Type l]
ts)
   where
    tuple :: Int -> Type
tuple = case Boxed
b of
      Boxed
Exts.Boxed   -> Int -> Type
TH.TupleT
      Boxed
Exts.Unboxed -> Int -> Type
TH.UnboxedTupleT
  toType (Exts.TyApp l
_ Type l
a Type l
b) = Type -> Type -> Type
TH.AppT (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
a) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
b)
  toType (Exts.TyVar l
_ Name l
n) = Name -> Type
TH.VarT (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n)
  toType (Exts.TyCon l
_ QName l
qn) = Name -> Type
TH.ConT (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
qn)
  toType (Exts.TyParen l
_ Type l
t) = Type l -> Type
forall a. ToType a => a -> Type
toType Type l
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 l
_ Type l
a (Exts.UnpromotedName l
_ QName l
o) Type l
b) =
    Type -> Type -> Type
TH.AppT (Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
o)) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
a)) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
b)
#else
  toType (Exts.TyInfix _ a o b) =
    TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b)
#endif
  toType (Exts.TyKind l
_ Type l
t Type l
k) = Type -> Type -> Type
TH.SigT (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t) (Type l -> Type
forall l. Kind l -> Type
toKind Type l
k)
  toType (Exts.TyPromoted l
_ Promoted l
p) = case Promoted l
p of
    Exts.PromotedInteger l
_ Integer
i String
_ -> TyLit -> Type
TH.LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ Integer -> TyLit
TH.NumTyLit Integer
i
    Exts.PromotedString l
_ String
_ String
s -> TyLit -> Type
TH.LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
TH.StrTyLit String
s
    Exts.PromotedCon l
_ Bool
_q QName l
n -> Name -> Type
TH.PromotedT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n
    Exts.PromotedList l
_ Bool
_q [Type l]
ts -> (Type l -> Type -> Type) -> Type -> [Type l] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Type l
t Type
pl -> Type
TH.PromotedConsT Type -> Type -> Type
`TH.AppT` Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t Type -> Type -> Type
`TH.AppT` Type
pl) Type
TH.PromotedNilT [Type l]
ts
    Exts.PromotedTuple l
_ [Type l]
ts -> (Type -> Type l -> Type) -> Type -> [Type l] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
pt Type l
t -> Type
pt Type -> Type -> Type
`TH.AppT` Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t) (Int -> Type
TH.PromotedTupleT (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ [Type l] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type l]
ts) [Type l]
ts
    Exts.PromotedUnit l
_ -> Name -> Type
TH.PromotedT ''()
  toType (Exts.TyEquals l
_ Type l
t1 Type l
t2) = Type
TH.EqualityT Type -> Type -> Type
`TH.AppT` Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t1 Type -> Type -> Type
`TH.AppT` Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t2
  toType t :: Type l
t@Exts.TySplice{} = String -> Type l -> Type
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toType" Type l
t
  toType t :: Type l
t@Exts.TyBang{} =
    String -> String -> Type l -> Type
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> String -> f e -> a
nonsense String
"toType" String
"type cannot have strictness annotations in this context" Type l
t
  toType t :: Type l
t@Exts.TyWildCard{} = String -> Type l -> Type
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toType" Type l
t
  toType Type l
t = String -> Type l -> Type
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"toType" Type l
t
  -- TODO
  -- toType (Exts.TyUnboxedSum _ _)
  -- toType (Exts.TyParArray _ _)
  -- toType (Exts.TyInfix _ _ (Exts.PromotedName _ _) _)

toStrictType :: Exts.Type l -> TH.StrictType
toStrictType :: Type l -> StrictType
toStrictType (Exts.TyBang l
_ BangType l
s Unpackedness l
u Type l
t) = (SourceUnpackedness -> SourceStrictness -> Bang
TH.Bang (Unpackedness l -> SourceUnpackedness
forall l. Unpackedness l -> SourceUnpackedness
toUnpack Unpackedness l
u) (BangType l -> SourceStrictness
forall l. BangType l -> SourceStrictness
toStrict BangType l
s), Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t)
    where
      toStrict :: BangType l -> SourceStrictness
toStrict (Exts.LazyTy l
_)        = SourceStrictness
TH.SourceLazy
      toStrict (Exts.BangedTy l
_)      = SourceStrictness
TH.SourceStrict
      toStrict (Exts.NoStrictAnnot l
_) = SourceStrictness
TH.NoSourceStrictness
      toUnpack :: Unpackedness l -> SourceUnpackedness
toUnpack (Exts.Unpack l
_)         = SourceUnpackedness
TH.SourceUnpack
      toUnpack (Exts.NoUnpack l
_)       = SourceUnpackedness
TH.SourceNoUnpack
      toUnpack (Exts.NoUnpackPragma l
_) = SourceUnpackedness
TH.NoSourceUnpackedness
toStrictType Type l
x = (SourceUnpackedness -> SourceStrictness -> Bang
TH.Bang SourceUnpackedness
TH.NoSourceUnpackedness SourceStrictness
TH.NoSourceStrictness, Type l -> Type
forall a. ToType a => a -> Type
toType Type l
x)

(.->.) :: TH.Type -> TH.Type -> TH.Type
Type
a .->. :: Type -> Type -> Type
.->. Type
b = Type -> Type -> Type
TH.AppT (Type -> Type -> Type
TH.AppT Type
TH.ArrowT Type
a) Type
b

instance ToPred (Exts.Asst l) where
#if MIN_VERSION_haskell_src_exts(1,22,0)
    toPred :: Asst l -> Type
toPred (Exts.TypeA l
_ Type l
t) = Type l -> Type
forall a. ToType a => a -> Type
toType Type l
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 l
_ Asst l
asst) = Asst l -> Type
forall a. ToPred a => a -> Type
toPred Asst l
asst
    toPred a :: Asst l
a@Exts.IParam{} = String -> Asst l -> Type
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toPred" Asst l
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 :: Deriving l -> [DerivClause]
toDerivClauses (Exts.Deriving l
_ Maybe (DerivStrategy l)
strat [InstRule l]
irules) = [Maybe DerivStrategy -> Cxt -> DerivClause
TH.DerivClause ((DerivStrategy l -> DerivStrategy)
-> Maybe (DerivStrategy l) -> Maybe DerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DerivStrategy l -> DerivStrategy
forall l. DerivStrategy l -> DerivStrategy
toDerivStrategy Maybe (DerivStrategy l)
strat) ((InstRule l -> Type) -> [InstRule l] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map InstRule l -> Type
forall a. ToType a => a -> Type
toType [InstRule l]
irules)]
#else
  toDerivClauses (Exts.Deriving _ irules) = [TH.DerivClause Nothing (map toType irules)]
#endif

instance ToDerivClauses a => ToDerivClauses (Maybe a) where
  toDerivClauses :: Maybe a -> [DerivClause]
toDerivClauses Maybe a
Nothing  = []
  toDerivClauses (Just a
a) = a -> [DerivClause]
forall a. ToDerivClauses a => a -> [DerivClause]
toDerivClauses a
a

instance ToDerivClauses a => ToDerivClauses [a] where
  toDerivClauses :: [a] -> [DerivClause]
toDerivClauses = (a -> [DerivClause]) -> [a] -> [DerivClause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [DerivClause]
forall a. ToDerivClauses a => a -> [DerivClause]
toDerivClauses


toDerivStrategy :: (Exts.DerivStrategy l) -> TH.DerivStrategy
toDerivStrategy :: DerivStrategy l -> DerivStrategy
toDerivStrategy (Exts.DerivStock l
_)    = DerivStrategy
TH.StockStrategy
toDerivStrategy (Exts.DerivAnyclass l
_) = DerivStrategy
TH.AnyclassStrategy
toDerivStrategy (Exts.DerivNewtype l
_)  = DerivStrategy
TH.NewtypeStrategy
#if MIN_VERSION_haskell_src_exts(1,21,0) && MIN_VERSION_template_haskell(2,14,0)
toDerivStrategy (Exts.DerivVia l
_ Type l
t)    = Type -> DerivStrategy
TH.ViaStrategy (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
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 :: Type -> Cxt -> Type
foldAppT Type
t Cxt
ts = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Type -> Type -> Type
TH.AppT Type
t Cxt
ts

-----------------------------------------------------------------------------

-- * ToStmt HsStmt

instance ToStmt (Exts.Stmt l) where
  toStmt :: Stmt l -> Stmt
toStmt (Exts.Generator l
_ Pat l
p Exp l
e)   = Pat -> Exp -> Stmt
TH.BindS (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toStmt (Exts.Qualifier l
_ Exp l
e)     = Exp -> Stmt
TH.NoBindS (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toStmt _a :: Stmt l
_a@(Exts.LetStmt l
_ Binds l
bnds) = [Dec] -> Stmt
TH.LetS (Binds l -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Binds l
bnds)
  toStmt s :: Stmt l
s@Exts.RecStmt{}         = String -> Stmt l -> Stmt
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toStmt" Stmt l
s


-----------------------------------------------------------------------------

-- * ToDec HsDecl

instance ToDec (Exts.Decl l) where
  toDec :: Decl l -> Dec
toDec (Exts.TypeDecl l
_ DeclHead l
h Type l
t)
    = Name -> [TyVarBndr_ flag] -> Type -> Dec
TH.TySynD (DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h) (DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t)

  toDec a :: Decl l
a@(Exts.DataDecl  l
_ DataOrNew l
dOrN Maybe (Context l)
cxt DeclHead l
h [QualConDecl l]
qcds [Deriving l]
qns)
    = case DataOrNew l
dOrN of
        Exts.DataType l
_ -> Cxt
-> Name
-> [TyVarBndr_ flag]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD (Maybe (Context l) -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt)
                             (DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h)
                             (DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h)
                             Maybe Type
forall a. Maybe a
Nothing
                             ((QualConDecl l -> Con) -> [QualConDecl l] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QualConDecl l -> Con
forall l. QualConDecl l -> Con
qualConDeclToCon [QualConDecl l]
qcds)
                             ([Deriving l] -> [DerivClause]
forall a. ToDerivClauses a => a -> [DerivClause]
toDerivClauses [Deriving l]
qns)
        Exts.NewType l
_  -> let qcd :: QualConDecl l
qcd = case [QualConDecl l]
qcds of
                                     [QualConDecl l
x] -> QualConDecl l
x
                                     [QualConDecl l]
_   -> String -> String -> Decl l -> QualConDecl l
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> String -> f e -> a
nonsense String
"toDec" (String
"newtype with " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                              String
"wrong number of constructors") Decl l
a
                        in Cxt
-> Name
-> [TyVarBndr_ flag]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
TH.NewtypeD (Maybe (Context l) -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt)
                                    (DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h)
                                    (DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h)
                                    Maybe Type
forall a. Maybe a
Nothing
                                    (QualConDecl l -> Con
forall l. QualConDecl l -> Con
qualConDeclToCon QualConDecl l
qcd)
                                    ([Deriving l] -> [DerivClause]
forall a. ToDerivClauses a => a -> [DerivClause]
toDerivClauses [Deriving l]
qns)

  -- This type-signature conversion is just wrong.
  -- Type variables need to be dealt with. /Jonas
  toDec _a :: Decl l
_a@(Exts.TypeSig l
_ [Name l]
ns Type l
t)
    -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!
    = let xs :: [Dec]
xs = (Name l -> Dec) -> [Name l] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name -> Type -> Dec) -> Type -> Name -> Dec
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Type -> Dec
TH.SigD (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t) (Name -> Dec) -> (Name l -> Name) -> Name l -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name l -> Name
forall a. ToName a => a -> Name
toName) [Name l]
ns
      in case [Dec]
xs of Dec
x:[Dec]
_ -> Dec
x; [] -> String -> Dec
forall a. HasCallStack => String -> a
error String
"toDec: malformed TypeSig!"

  toDec (Exts.InlineConlikeSig l
_ Maybe (Activation l)
act QName l
qn) = Pragma -> Dec
TH.PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$
    Name -> Inline -> RuleMatch -> Phases -> Pragma
TH.InlineP (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
qn) Inline
TH.Inline RuleMatch
TH.ConLike (Maybe (Activation l) -> Phases
forall l. Maybe (Activation l) -> Phases
transAct Maybe (Activation l)
act)
  toDec (Exts.InlineSig l
_ Bool
b Maybe (Activation l)
act QName l
qn) = Pragma -> Dec
TH.PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$
    Name -> Inline -> RuleMatch -> Phases -> Pragma
TH.InlineP (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
qn) Inline
inline RuleMatch
TH.FunLike (Maybe (Activation l) -> Phases
forall l. Maybe (Activation l) -> Phases
transAct Maybe (Activation l)
act)
   where
    inline :: Inline
inline | Bool
b = Inline
TH.Inline | Bool
otherwise = Inline
TH.NoInline

  toDec (Exts.TypeFamDecl l
_ DeclHead l
h Maybe (ResultSig l)
sig Maybe (InjectivityInfo l)
inj)
    = TypeFamilyHead -> Dec
TH.OpenTypeFamilyD (TypeFamilyHead -> Dec) -> TypeFamilyHead -> Dec
forall a b. (a -> b) -> a -> b
$ Name
-> [TyVarBndr_ flag]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TH.TypeFamilyHead (DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h)
                                       (DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h)
                                       (FamilyResultSig
-> (Type -> FamilyResultSig) -> Maybe Type -> FamilyResultSig
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FamilyResultSig
TH.NoSig Type -> FamilyResultSig
TH.KindSig (Maybe Type -> FamilyResultSig)
-> (Maybe (ResultSig l) -> Maybe Type)
-> Maybe (ResultSig l)
-> FamilyResultSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (ResultSig l) -> Maybe Type
forall a. ToMaybeKind a => a -> Maybe Type
toMaybeKind (Maybe (ResultSig l) -> FamilyResultSig)
-> Maybe (ResultSig l) -> FamilyResultSig
forall a b. (a -> b) -> a -> b
$ Maybe (ResultSig l)
sig)
                                       ((InjectivityInfo l -> InjectivityAnn)
-> Maybe (InjectivityInfo l) -> Maybe InjectivityAnn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InjectivityInfo l -> InjectivityAnn
forall a. ToInjectivityAnn a => a -> InjectivityAnn
toInjectivityAnn Maybe (InjectivityInfo l)
inj)
  toDec (Exts.DataFamDecl l
_ Maybe (Context l)
_ DeclHead l
h Maybe (ResultSig l)
sig)
    = Name -> [TyVarBndr_ flag] -> Maybe Type -> Dec
TH.DataFamilyD (DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h) (DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h) (Maybe (ResultSig l) -> Maybe Type
forall a. ToMaybeKind a => a -> Maybe Type
toMaybeKind Maybe (ResultSig l)
sig)

  toDec _a :: Decl l
_a@(Exts.FunBind l
_ [Match l]
mtchs)                           = [Match l] -> Dec
forall l. [Match l] -> Dec
hsMatchesToFunD [Match l]
mtchs
  toDec (Exts.PatBind l
_ Pat l
p Rhs l
rhs Maybe (Binds l)
bnds)                      = Pat -> Body -> [Dec] -> Dec
TH.ValD (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p)
                                                              (Rhs l -> Body
forall l. Rhs l -> Body
hsRhsToBody Rhs l
rhs)
                                                              (Maybe (Binds l) -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Maybe (Binds l)
bnds)

  toDec i :: Decl l
i@(Exts.InstDecl l
_ (Just Overlap l
overlap) InstRule l
_ Maybe [InstDecl l]
_) =
    String -> (Overlap (), Decl l) -> Dec
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toDec" ((l -> ()) -> Overlap l -> Overlap ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> l -> ()
forall a b. a -> b -> a
const ()) Overlap l
overlap, Decl l
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 l
_ Maybe (Overlap l)
Nothing InstRule l
irule Maybe [InstDecl l]
ids) = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
TH.InstanceD
    Maybe Overlap
forall a. Maybe a
Nothing
    (InstRule l -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt InstRule l
irule)
    (InstRule l -> Type
forall a. ToType a => a -> Type
toType InstRule l
irule)
    (Maybe [InstDecl l] -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Maybe [InstDecl l]
ids)

  toDec (Exts.ClassDecl l
_ Maybe (Context l)
cxt DeclHead l
h [FunDep l]
fds Maybe [ClassDecl l]
decls) = Cxt -> Name -> [TyVarBndr_ flag] -> [FunDep] -> [Dec] -> Dec
TH.ClassD
    (Maybe (Context l) -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt)
    (DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h)
    (DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h)
    ((FunDep l -> FunDep) -> [FunDep l] -> [FunDep]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FunDep l -> FunDep
forall l. FunDep l -> FunDep
toFunDep [FunDep l]
fds)
    (Maybe [ClassDecl l] -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Maybe [ClassDecl l]
decls)
   where
    toFunDep :: FunDep l -> FunDep
toFunDep (Exts.FunDep l
_ [Name l]
ls [Name l]
rs) = [Name] -> [Name] -> FunDep
TH.FunDep ((Name l -> Name) -> [Name l] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name l -> Name
forall a. ToName a => a -> Name
toName [Name l]
ls) ((Name l -> Name) -> [Name l] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name l -> Name
forall a. ToName a => a -> Name
toName [Name l]
rs)

  toDec (Exts.AnnPragma l
_ Annotation l
ann) = Pragma -> Dec
TH.PragmaD (AnnTarget -> Exp -> Pragma
TH.AnnP (Annotation l -> AnnTarget
forall l. Annotation l -> AnnTarget
target Annotation l
ann) (Annotation l -> Exp
forall l. Annotation l -> Exp
expann Annotation l
ann))
    where
      target :: Annotation l -> AnnTarget
target (Exts.Ann l
_ Name l
n Exp l
_)     = Name -> AnnTarget
TH.ValueAnnotation (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n)
      target (Exts.TypeAnn l
_ Name l
n Exp l
_) = Name -> AnnTarget
TH.TypeAnnotation (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n)
      target (Exts.ModuleAnn l
_ Exp l
_) = AnnTarget
TH.ModuleAnnotation
      expann :: Annotation l -> Exp
expann (Exts.Ann l
_ Name l
_ Exp l
e)     = Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e
      expann (Exts.TypeAnn l
_ Name l
_ Exp l
e) = Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e
      expann (Exts.ModuleAnn l
_ Exp l
e) = Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e

  toDec Decl l
x = String -> Decl l -> Dec
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"toDec" Decl l
x

instance ToMaybeKind (Exts.ResultSig l) where
    toMaybeKind :: ResultSig l -> Maybe Type
toMaybeKind (Exts.KindSig l
_ Kind l
k)  = Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Kind l -> Type
forall l. Kind l -> Type
toKind Kind l
k
    toMaybeKind (Exts.TyVarSig l
_ TyVarBind l
_) = Maybe Type
forall a. Maybe a
Nothing

instance ToMaybeKind a => ToMaybeKind (Maybe a) where
    toMaybeKind :: Maybe a -> Maybe Type
toMaybeKind Maybe a
Nothing  = Maybe Type
forall a. Maybe a
Nothing
    toMaybeKind (Just a
a) = a -> Maybe Type
forall a. ToMaybeKind a => a -> Maybe Type
toMaybeKind a
a

instance ToInjectivityAnn (Exts.InjectivityInfo l) where
  toInjectivityAnn :: InjectivityInfo l -> InjectivityAnn
toInjectivityAnn (Exts.InjectivityInfo l
_ Name l
n [Name l]
ns) = Name -> [Name] -> InjectivityAnn
TH.InjectivityAnn (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n) ((Name l -> Name) -> [Name l] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name l -> Name
forall a. ToName a => a -> Name
toName [Name l]
ns)

transAct :: Maybe (Exts.Activation l) -> TH.Phases
transAct :: Maybe (Activation l) -> Phases
transAct Maybe (Activation l)
Nothing                       = Phases
TH.AllPhases
transAct (Just (Exts.ActiveFrom l
_ Int
n))  = Int -> Phases
TH.FromPhase Int
n
transAct (Just (Exts.ActiveUntil l
_ Int
n)) = Int -> Phases
TH.BeforePhase Int
n

instance ToName (Exts.DeclHead l) where
  toName :: DeclHead l -> Name
toName (Exts.DHead l
_ Name l
n)     = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.DHInfix l
_ TyVarBind l
_ Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.DHParen l
_ DeclHead l
h)   = DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h
  toName (Exts.DHApp l
_ DeclHead l
h TyVarBind l
_)   = DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h

instance ToTyVars (Exts.DeclHead l) where
  toTyVars :: DeclHead l -> [TyVarBndr_ flag]
toTyVars (Exts.DHead l
_ Name l
_)       = []
  toTyVars (Exts.DHParen l
_ DeclHead l
h)     = DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h
  toTyVars (Exts.DHInfix l
_ TyVarBind l
tvb Name l
_) = [TyVarBind l -> TyVarBndr_ flag
forall l. TyVarBind l -> TyVarBndr_ flag
toTyVar TyVarBind l
tvb]
  toTyVars (Exts.DHApp l
_ DeclHead l
h TyVarBind l
tvb)   = DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h [TyVarBndr_ flag] -> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
forall a. [a] -> [a] -> [a]
++ [TyVarBind l -> TyVarBndr_ flag
forall l. TyVarBind l -> TyVarBndr_ flag
toTyVar TyVarBind l
tvb]

instance ToNames a => ToNames (Maybe a) where
  toNames :: Maybe a -> [Name]
toNames Maybe a
Nothing  = []
  toNames (Just a
a) = a -> [Name]
forall a. ToNames a => a -> [Name]
toNames a
a

instance ToNames (Exts.Deriving l) where
#if MIN_VERSION_haskell_src_exts(1,20,0)
  toNames :: Deriving l -> [Name]
toNames (Exts.Deriving l
_ Maybe (DerivStrategy l)
_ [InstRule l]
irules) = (InstRule l -> [Name]) -> [InstRule l] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InstRule l -> [Name]
forall a. ToNames a => a -> [Name]
toNames [InstRule l]
irules
#else
  toNames (Exts.Deriving _ irules)   = concatMap toNames irules
#endif

instance ToNames (Exts.InstRule l) where
  toNames :: InstRule l -> [Name]
toNames (Exts.IParen l
_ InstRule l
irule)            = InstRule l -> [Name]
forall a. ToNames a => a -> [Name]
toNames InstRule l
irule
  toNames (Exts.IRule l
_ Maybe [TyVarBind l]
_mtvbs Maybe (Context l)
_mcxt InstHead l
mihd) = InstHead l -> [Name]
forall a. ToNames a => a -> [Name]
toNames InstHead l
mihd
instance ToNames (Exts.InstHead l) where
  toNames :: InstHead l -> [Name]
toNames (Exts.IHCon l
_ QName l
n)     = [QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n]
  toNames (Exts.IHInfix l
_ Type l
_ QName l
n) = [QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n]
  toNames (Exts.IHParen l
_ InstHead l
h)   = InstHead l -> [Name]
forall a. ToNames a => a -> [Name]
toNames InstHead l
h
  toNames (Exts.IHApp l
_ InstHead l
h Type l
_)   = InstHead l -> [Name]
forall a. ToNames a => a -> [Name]
toNames InstHead l
h

instance ToCxt (Exts.InstRule l) where
  toCxt :: InstRule l -> Cxt
toCxt (Exts.IRule l
_ Maybe [TyVarBind l]
_ Maybe (Context l)
cxt InstHead l
_) = Maybe (Context l) -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt
  toCxt (Exts.IParen l
_ InstRule l
irule)  = InstRule l -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt InstRule l
irule

instance ToCxt (Exts.Context l) where
  toCxt :: Context l -> Cxt
toCxt Context l
x = case Context l
x of
              Exts.CxEmpty l
_     -> []
              Exts.CxSingle l
_ Asst l
x' -> [Asst l -> Type
forall a. ToPred a => a -> Type
toPred Asst l
x']
              Exts.CxTuple l
_ [Asst l]
xs  -> (Asst l -> Type) -> [Asst l] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Asst l -> Type
forall a. ToPred a => a -> Type
toPred [Asst l]
xs

instance ToCxt a => ToCxt (Maybe a) where
    toCxt :: Maybe a -> Cxt
toCxt Maybe a
Nothing  = []
    toCxt (Just a
a) = a -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt a
a

instance ToType (Exts.InstRule l) where
    toType :: InstRule l -> Type
toType (Exts.IRule l
_ Maybe [TyVarBind l]
_ Maybe (Context l)
_ InstHead l
h)  = InstHead l -> Type
forall a. ToType a => a -> Type
toType InstHead l
h
    toType (Exts.IParen l
_ InstRule l
irule) = InstRule l -> Type
forall a. ToType a => a -> Type
toType InstRule l
irule

instance ToType (Exts.InstHead l) where
    toType :: InstHead l -> Type
toType (Exts.IHCon l
_ QName l
qn)       = QName l -> Type
forall a. ToType a => a -> Type
toType QName l
qn
    toType (Exts.IHInfix l
_ Type l
typ QName l
qn) = Type -> Type -> Type
TH.AppT (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
typ) (QName l -> Type
forall a. ToType a => a -> Type
toType QName l
qn)
    toType (Exts.IHParen l
_ InstHead l
hd)     = InstHead l -> Type
forall a. ToType a => a -> Type
toType InstHead l
hd
    toType (Exts.IHApp l
_ InstHead l
hd Type l
typ)   = Type -> Type -> Type
TH.AppT (InstHead l -> Type
forall a. ToType a => a -> Type
toType InstHead l
hd) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
typ)

qualConDeclToCon :: Exts.QualConDecl l -> TH.Con
qualConDeclToCon :: QualConDecl l -> Con
qualConDeclToCon (Exts.QualConDecl l
_ Maybe [TyVarBind l]
Nothing Maybe (Context l)
Nothing ConDecl l
cdecl) = ConDecl l -> Con
forall l. ConDecl l -> Con
conDeclToCon ConDecl l
cdecl
qualConDeclToCon (Exts.QualConDecl l
_ Maybe [TyVarBind l]
ns Maybe (Context l)
cxt ConDecl l
cdecl) = [TyVarBndr_ flag] -> Cxt -> Con -> Con
TH.ForallC (TyVarBndr_ flag -> TyVarBndr_ flag
forall flag. TyVarBndr_ flag -> TyVarBndr_ flag
toTyVarSpec (TyVarBndr_ flag -> TyVarBndr_ flag)
-> [TyVarBndr_ flag] -> [TyVarBndr_ flag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [TyVarBind l] -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars Maybe [TyVarBind l]
ns)
                                                    (Maybe (Context l) -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt)
                                                    (ConDecl l -> Con
forall l. ConDecl l -> Con
conDeclToCon ConDecl l
cdecl)

instance ToTyVars a => ToTyVars (Maybe a) where
  toTyVars :: Maybe a -> [TyVarBndr_ flag]
toTyVars Maybe a
Nothing  = []
  toTyVars (Just a
a) = a -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars a
a

instance ToTyVars a => ToTyVars [a] where
  toTyVars :: [a] -> [TyVarBndr_ flag]
toTyVars = (a -> [TyVarBndr_ flag]) -> [a] -> [TyVarBndr_ flag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars

instance ToTyVars (Exts.TyVarBind l) where
  toTyVars :: TyVarBind l -> [TyVarBndr_ flag]
toTyVars TyVarBind l
tvb = [TyVarBind l -> TyVarBndr_ flag
forall l. TyVarBind l -> TyVarBndr_ flag
toTyVar TyVarBind l
tvb]

instance ToType (Exts.QName l) where
    toType :: QName l -> Type
toType = Name -> Type
TH.ConT (Name -> Type) -> (QName l -> Name) -> QName l -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName l -> Name
forall a. ToName a => a -> Name
toName

conDeclToCon :: Exts.ConDecl l -> TH.Con
conDeclToCon :: ConDecl l -> Con
conDeclToCon (Exts.ConDecl l
_ Name l
n [Type l]
tys)
  = Name -> [StrictType] -> Con
TH.NormalC (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n) ((Type l -> StrictType) -> [Type l] -> [StrictType]
forall a b. (a -> b) -> [a] -> [b]
map Type l -> StrictType
forall l. Type l -> StrictType
toStrictType [Type l]
tys)
conDeclToCon (Exts.RecDecl l
_ Name l
n [FieldDecl l]
fieldDecls)
  = Name -> [VarBangType] -> Con
TH.RecC (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n) ((FieldDecl l -> [VarBangType]) -> [FieldDecl l] -> [VarBangType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FieldDecl l -> [VarBangType]
forall l. FieldDecl l -> [VarBangType]
convField [FieldDecl l]
fieldDecls)
  where
    convField :: Exts.FieldDecl l -> [TH.VarStrictType]
    convField :: FieldDecl l -> [VarBangType]
convField (Exts.FieldDecl l
_ [Name l]
ns Type l
t) =
      let (Bang
strict, Type
ty) = Type l -> StrictType
forall l. Type l -> StrictType
toStrictType Type l
t
      in (Name l -> VarBangType) -> [Name l] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map (\Name l
n' -> (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n', Bang
strict, Type
ty)) [Name l]
ns
conDeclToCon ConDecl l
h = String -> ConDecl l -> Con
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"conDeclToCon" ConDecl l
h
-- TODO
-- (Exts.InfixConDecl _ _ _ _)


hsMatchesToFunD :: [Exts.Match l] -> TH.Dec
hsMatchesToFunD :: [Match l] -> Dec
hsMatchesToFunD [] = Name -> [Clause] -> Dec
TH.FunD (String -> Name
TH.mkName []) []   -- errorish
hsMatchesToFunD xs :: [Match l]
xs@(Exts.Match l
_ Name l
n [Pat l]
_ Rhs l
_ Maybe (Binds l)
_ : [Match l]
_) = Name -> [Clause] -> Dec
TH.FunD (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n) ((Match l -> Clause) -> [Match l] -> [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Match l -> Clause
forall l. Match l -> Clause
hsMatchToClause [Match l]
xs)
hsMatchesToFunD xs :: [Match l]
xs@(Exts.InfixMatch l
_ Pat l
_ Name l
n [Pat l]
_ Rhs l
_ Maybe (Binds l)
_ : [Match l]
_) = Name -> [Clause] -> Dec
TH.FunD (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n) ((Match l -> Clause) -> [Match l] -> [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Match l -> Clause
forall l. Match l -> Clause
hsMatchToClause [Match l]
xs)


hsMatchToClause :: Exts.Match l -> TH.Clause
hsMatchToClause :: Match l -> Clause
hsMatchToClause (Exts.Match l
_ Name l
_ [Pat l]
ps Rhs l
rhs Maybe (Binds l)
bnds) = [Pat] -> Body -> [Dec] -> Clause
TH.Clause
                                                ((Pat l -> Pat) -> [Pat l] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
                                                (Rhs l -> Body
forall l. Rhs l -> Body
hsRhsToBody Rhs l
rhs)
                                                (Maybe (Binds l) -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Maybe (Binds l)
bnds)
hsMatchToClause (Exts.InfixMatch l
_ Pat l
p Name l
_ [Pat l]
ps Rhs l
rhs Maybe (Binds l)
bnds) = [Pat] -> Body -> [Dec] -> Clause
TH.Clause
                                                        ((Pat l -> Pat) -> [Pat l] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat (Pat l
pPat l -> [Pat l] -> [Pat l]
forall a. a -> [a] -> [a]
:[Pat l]
ps))
                                                        (Rhs l -> Body
forall l. Rhs l -> Body
hsRhsToBody Rhs l
rhs)
                                                        (Maybe (Binds l) -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Maybe (Binds l)
bnds)



hsRhsToBody :: Exts.Rhs l -> TH.Body
hsRhsToBody :: Rhs l -> Body
hsRhsToBody (Exts.UnGuardedRhs l
_ Exp l
e) = Exp -> Body
TH.NormalB (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
hsRhsToBody (Exts.GuardedRhss l
_ [GuardedRhs l]
hsgrhs) =
  let fromGuardedB :: Body -> [(Guard, Exp)]
fromGuardedB (TH.GuardedB [(Guard, Exp)]
a) = [(Guard, Exp)]
a
      fromGuardedB Body
h               = String -> [Body] -> [(Guard, Exp)]
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"fromGuardedB" [Body
h]
      -- TODO: (NormalB _)
  in [(Guard, Exp)] -> Body
TH.GuardedB ([(Guard, Exp)] -> Body)
-> ([GuardedRhs l] -> [(Guard, Exp)]) -> [GuardedRhs l] -> Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Guard, Exp)]] -> [(Guard, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
     ([[(Guard, Exp)]] -> [(Guard, Exp)])
-> ([GuardedRhs l] -> [[(Guard, Exp)]])
-> [GuardedRhs l]
-> [(Guard, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GuardedRhs l -> [(Guard, Exp)])
-> [GuardedRhs l] -> [[(Guard, Exp)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Body -> [(Guard, Exp)]
fromGuardedB (Body -> [(Guard, Exp)])
-> (GuardedRhs l -> Body) -> GuardedRhs l -> [(Guard, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GuardedRhs l -> Body
forall l. GuardedRhs l -> Body
hsGuardedRhsToBody)
     ([GuardedRhs l] -> Body) -> [GuardedRhs l] -> Body
forall a b. (a -> b) -> a -> b
$ [GuardedRhs l]
hsgrhs


hsGuardedRhsToBody :: Exts.GuardedRhs l -> TH.Body
hsGuardedRhsToBody :: GuardedRhs l -> Body
hsGuardedRhsToBody (Exts.GuardedRhs l
_ [] Exp l
e)  = Exp -> Body
TH.NormalB (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
hsGuardedRhsToBody (Exts.GuardedRhs l
_ [Stmt l
s] Exp l
e) = [(Guard, Exp)] -> Body
TH.GuardedB [(Stmt l -> Guard
forall l. Stmt l -> Guard
hsStmtToGuard Stmt l
s, Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)]
hsGuardedRhsToBody (Exts.GuardedRhs l
_ [Stmt l]
ss Exp l
e)  = let ss' :: [Guard]
ss' = (Stmt l -> Guard) -> [Stmt l] -> [Guard]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stmt l -> Guard
forall l. Stmt l -> Guard
hsStmtToGuard [Stmt l]
ss
                                                   ([[Stmt]]
pgs,[Guard]
ngs) = [([Stmt], Guard)] -> ([[Stmt]], [Guard])
forall a b. [(a, b)] -> ([a], [b])
unzip [([Stmt]
p,Guard
n)
                                                                     | (TH.PatG [Stmt]
p) <- [Guard]
ss'
                                                                     , n :: Guard
n@(TH.NormalG Exp
_) <- [Guard]
ss']
                                                   e' :: Exp
e' = Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e
                                                   patg :: Guard
patg = [Stmt] -> Guard
TH.PatG ([[Stmt]] -> [Stmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Stmt]]
pgs)
                                               in [(Guard, Exp)] -> Body
TH.GuardedB ([(Guard, Exp)] -> Body) -> [(Guard, Exp)] -> Body
forall a b. (a -> b) -> a -> b
$ (Guard
patg,Exp
e') (Guard, Exp) -> [(Guard, Exp)] -> [(Guard, Exp)]
forall a. a -> [a] -> [a]
: [Guard] -> [Exp] -> [(Guard, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Guard]
ngs (Exp -> [Exp]
forall a. a -> [a]
repeat Exp
e')



hsStmtToGuard :: Exts.Stmt l -> TH.Guard
hsStmtToGuard :: Stmt l -> Guard
hsStmtToGuard (Exts.Generator l
_ Pat l
p Exp l
e) = [Stmt] -> Guard
TH.PatG [Pat -> Exp -> Stmt
TH.BindS (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)]
hsStmtToGuard (Exts.Qualifier l
_ Exp l
e)   = Exp -> Guard
TH.NormalG (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
hsStmtToGuard (Exts.LetStmt l
_ Binds l
bs)    = [Stmt] -> Guard
TH.PatG [[Dec] -> Stmt
TH.LetS (Binds l -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Binds l
bs)]
hsStmtToGuard Stmt l
h                      = String -> Stmt l -> Guard
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"hsStmtToGuard" Stmt l
h
-- TODO
-- (Exts.RecStmt _ _)


-----------------------------------------------------------------------------

-- * ToDecs InstDecl
instance ToDecs (Exts.InstDecl l) where
  toDecs :: InstDecl l -> [Dec]
toDecs (Exts.InsDecl l
_ Decl l
decl) = Decl l -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Decl l
decl
  toDecs InstDecl l
d                     = String -> InstDecl l -> [Dec]
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo String
"toDec" InstDecl l
d

-- * ToDecs HsDecl HsBinds

instance ToDecs (Exts.Decl l) where
  toDecs :: Decl l -> [Dec]
toDecs _a :: Decl l
_a@(Exts.TypeSig l
_ [Name l]
ns Type l
t)
    -- TODO: fixforall as before?
    -- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns
    = let xs :: [Dec]
xs = (Name l -> Dec) -> [Name l] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name -> Type -> Dec) -> Type -> Name -> Dec
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Type -> Dec
TH.SigD (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t) (Name -> Dec) -> (Name l -> Name) -> Name l -> Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name l -> Name
forall a. ToName a => a -> Name
toName) [Name l]
ns
       in [Dec]
xs

  toDecs (Exts.InfixDecl l
l Assoc l
assoc Maybe Int
Nothing [Op l]
ops) =
      Decl l -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs (l -> Assoc l -> Maybe Int -> [Op l] -> Decl l
forall l. l -> Assoc l -> Maybe Int -> [Op l] -> Decl l
Exts.InfixDecl l
l Assoc l
assoc (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
9) [Op l]
ops)
  toDecs (Exts.InfixDecl l
_ Assoc l
assoc (Just Int
fixity) [Op l]
ops) =
    (Op l -> Dec) -> [Op l] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (\Op l
op -> Fixity -> Name -> Dec
TH.InfixD (Int -> FixityDirection -> Fixity
TH.Fixity Int
fixity FixityDirection
dir) (Op l -> Name
forall a. ToName a => a -> Name
toName Op l
op)) [Op l]
ops
   where
    dir :: FixityDirection
dir = case Assoc l
assoc of
      Exts.AssocNone l
_  -> FixityDirection
TH.InfixN
      Exts.AssocLeft l
_  -> FixityDirection
TH.InfixL
      Exts.AssocRight l
_ -> FixityDirection
TH.InfixR

  toDecs Decl l
a = [Decl l -> Dec
forall a. ToDec a => a -> Dec
toDec Decl l
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] -> [Dec]
toDecs [a]
a = (a -> [Dec]) -> [a] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs [a]
a