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

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

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

nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a
nonsense :: forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> String -> f e -> a
nonsense String
fun String
inparticular f e
thing = forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [String
moduleName, String
".", String
fun,
  String
": nonsensical: ", String
inparticular, String
": ", forall a. Show a => a -> String
show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 :: forall a. ToExp a => a -> Maybe Exp
toTupEl = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 [forall a. ToExp a => a -> Maybe Exp
toTupEl a
a, 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 [forall a. ToExp a => a -> Maybe Exp
toTupEl a
a, forall a. ToExp a => a -> Maybe Exp
toTupEl b
b, 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 [forall a. ToExp a => a -> Maybe Exp
toTupEl a
a, forall a. ToExp a => a -> Maybe Exp
toTupEl b
b, forall a. ToExp a => a -> Maybe Exp
toTupEl c
c, 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 [forall a. ToPat a => a -> Pat
toPat a
a, 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 [forall a. ToPat a => a -> Pat
toPat a
a, forall a. ToPat a => a -> Pat
toPat b
b, 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 [forall a. ToPat a => a -> Pat
toPat a
a, forall a. ToPat a => a -> Pat
toPat b
b, forall a. ToPat a => a -> Pat
toPat c
c, 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger
instance ToLit Float where
  toLit :: Float -> Lit
toLit = Rational -> Lit
TH.RationalL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational
instance ToLit Double where
  toLit :: Double -> Lit
toLit = Rational -> Lit
TH.RationalL forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)  = forall a. ToName a => a -> Name
toName String
s
  toName (Exts.Symbol l
_ String
s) = 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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(",forall a. Int -> a -> [a]
replicate (Int
nforall 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 = 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) = 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' = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName forall a b. (a -> b) -> a -> b
$ String
m
        n' :: String
n' = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName forall a b. (a -> b) -> a -> b
$ Name l
n
    in forall a. ToName a => a -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [String
m',String
".",String
n']
  toName (Exts.UnQual l
_ Name l
n) = forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.Special l
_ SpecialCon l
s) = 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) = forall a. ToName a => a -> Name
toName QName l
qn
  toName (Exts.UnpromotedName l
_ QName l
qn) = 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) = forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.ConOp l
_ Name l
n) = 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{} = 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 (forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
toWord8 String
a)
   where
    toWord8 :: Char -> Word8
toWord8 = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 (forall a. ToName a => a -> Name
toName Name l
n)
  toPat (Exts.PLit l
_ (Exts.Signless l
_) Literal l
l)
    = Lit -> Pat
TH.LitP (forall a. ToLit a => a -> Lit
toLit Literal l
l)
  toPat (Exts.PLit l
_ (Exts.Negative l
_) Literal l
l) = Lit -> Pat
TH.LitP forall a b. (a -> b) -> a -> b
$ case forall a. ToLit a => a -> Lit
toLit Literal l
l of
    TH.IntegerL Integer
z      -> Integer -> Lit
TH.IntegerL (forall a. Num a => a -> a
negate Integer
z)
    TH.RationalL Rational
q     -> Rational -> Lit
TH.RationalL (forall a. Num a => a -> a
negate Rational
q)
    TH.IntPrimL Integer
z'     -> Integer -> Lit
TH.IntPrimL (forall a. Num a => a -> a
negate Integer
z')
    TH.FloatPrimL Rational
r'   -> Rational -> Lit
TH.FloatPrimL (forall a. Num a => a -> a
negate Rational
r')
    TH.DoublePrimL Rational
r'' -> Rational -> Lit
TH.DoublePrimL (forall a. Num a => a -> a
negate Rational
r'')
    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 (forall a. ToPat a => a -> Pat
toPat Pat l
p) (forall a. ToName a => a -> Name
toName QName l
n) (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 (forall a. ToName a => a -> Name
toName QName l
n) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
  toPat (Exts.PTuple l
_ Boxed
Exts.Boxed [Pat l]
ps) = [Pat] -> Pat
TH.TupP (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
  toPat (Exts.PTuple l
_ Boxed
Exts.Unboxed [Pat l]
ps) = [Pat] -> Pat
TH.UnboxedTupP (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
  toPat (Exts.PList l
_ [Pat l]
ps) = [Pat] -> Pat
TH.ListP (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
  toPat (Exts.PParen l
_ Pat l
p) = Pat -> Pat
TH.ParensP (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) = (forall a. ToName a => a -> Name
toName QName e
n', forall a. ToPat a => a -> Pat
toPat Pat e
p)
                                  toFieldPat PatField e
h = 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 (forall a. ToName a => a -> Name
toName QName l
n) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 (forall a. ToName a => a -> Name
toName Name l
n) (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 (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 (forall a. ToPat a => a -> Pat
toPat Pat l
p) (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 (forall a. ToExp a => a -> Exp
toExp Exp l
e) (forall a. ToPat a => a -> Pat
toPat Pat l
p)
  -- regular pattern
  toPat p :: Pat l
p@Exts.PRPat{} = 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{} = 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{} = 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{} = 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{} = 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 (forall a. ToPat a => a -> Pat
toPat Pat l
p)
  toPat Pat l
p = 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 (forall a. ToName a => a -> Name
toName QName l
n)
  toExp (Exts.QConOp l
_ QName l
n) = Name -> Exp
TH.ConE (forall a. ToName a => a -> Name
toName QName l
n)

toFieldExp :: Exts.FieldUpdate l -> TH.FieldExp
toFieldExp :: forall l. FieldUpdate l -> FieldExp
toFieldExp (Exts.FieldUpdate l
_ QName l
n Exp l
e) = (forall a. ToName a => a -> Name
toName QName l
n, forall a. ToExp a => a -> Exp
toExp Exp l
e)
toFieldExp FieldUpdate l
h                        = 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 (forall a. ToName a => a -> Name
toName QName l
n)
  toExp e :: Exp l
e@Exts.IPVar{}                 = 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 (forall a. ToName a => a -> Name
toName QName l
n)
  toExp (Exts.Lit l
_ Literal l
l)                 = Lit -> Exp
TH.LitE (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 (forall a. ToExp a => a -> Exp
toExp Exp l
e) (forall a. ToExp a => a -> Exp
toExp QOp l
o) (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 (forall a. ToExp a => a -> Exp
toExp Exp l
e) (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 (forall a. ToExp a => a -> Exp
toExp Exp l
e) (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) (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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToPat a => a -> Pat
toPat [Pat l]
ps) (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 (forall a. ToDecs a => a -> [Dec]
toDecs Binds l
bs) (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 (forall a. ToExp a => a -> Exp
toExp Exp l
a) (forall a. ToExp a => a -> Exp
toExp Exp l
b) (forall a. ToExp a => a -> Exp
toExp Exp l
c)
  toExp (Exts.MultiIf l
_ [GuardedRhs l]
ifs)           = [(Guard, Exp)] -> Exp
TH.MultiIfE (forall a b. (a -> b) -> [a] -> [b]
map 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 (forall a. ToExp a => a -> Exp
toExp Exp l
e) (forall a b. (a -> b) -> [a] -> [b]
map forall l. Alt l -> Match
toMatch [Alt l]
alts)
#if MIN_VERSION_template_haskell(2,17,0)
  toExp (Exts.Do l
_ [Stmt l]
ss)                 = Maybe ModName -> [Stmt] -> Exp
TH.DoE forall a. Maybe a
Nothing (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToStmt a => a -> Stmt
toStmt [Stmt l]
ss)
#else
  toExp (Exts.Do _ ss)                 = TH.DoE (map toStmt ss)
#endif
  toExp e :: Exp l
e@Exts.MDo{}                   = 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToExp a => a -> Maybe Exp
toTupEl [Exp l]
xs)
  toExp e :: Exp l
e@Exts.TupleSection{}          = 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToExp a => a -> Exp
toExp [Exp l]
xs)
  toExp (Exts.Paren l
_ Exp l
e)               = Exp -> Exp
TH.ParensE (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 (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExp a => a -> Exp
toExp forall a b. (a -> b) -> a -> b
$ Exp l
e) (forall a. ToExp a => a -> Exp
toExp QOp l
o) forall a. Maybe a
Nothing
  toExp (Exts.RightSection l
_ QOp l
o Exp l
f)      = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE forall a. Maybe a
Nothing (forall a. ToExp a => a -> Exp
toExp QOp l
o) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToExp a => a -> Exp
toExp 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 (forall a. ToName a => a -> Name
toName QName l
n) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l. FieldUpdate l -> FieldExp
toFieldExp [FieldUpdate l]
xs)
  toExp (Exts.RecUpdate l
_ Exp l
e [FieldUpdate l]
xs)        = Exp -> [FieldExp] -> Exp
TH.RecUpdE (forall a. ToExp a => a -> Exp
toExp Exp l
e) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l. FieldUpdate l -> FieldExp
toFieldExp [FieldUpdate l]
xs)
  toExp (Exts.EnumFrom l
_ Exp l
e)            = Range -> Exp
TH.ArithSeqE forall a b. (a -> b) -> a -> b
$ Exp -> Range
TH.FromR (forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toExp (Exts.EnumFromTo l
_ Exp l
e Exp l
f)        = Range -> Exp
TH.ArithSeqE forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Range
TH.FromToR (forall a. ToExp a => a -> Exp
toExp Exp l
e) (forall a. ToExp a => a -> Exp
toExp Exp l
f)
  toExp (Exts.EnumFromThen l
_ Exp l
e Exp l
f)      = Range -> Exp
TH.ArithSeqE forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Range
TH.FromThenR (forall a. ToExp a => a -> Exp
toExp Exp l
e) (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 forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Range
TH.FromThenToR (forall a. ToExp a => a -> Exp
toExp Exp l
e) (forall a. ToExp a => a -> Exp
toExp Exp l
f) (forall a. ToExp a => a -> Exp
toExp Exp l
g)
  toExp (Exts.ListComp l
_ Exp l
e [QualStmt l]
ss)         = [Stmt] -> Exp
TH.CompE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {e}. QualStmt e -> Stmt
convert [QualStmt l]
ss forall a. [a] -> [a] -> [a]
++ [Exp -> Stmt
TH.NoBindS (forall a. ToExp a => a -> Exp
toExp Exp l
e)]
   where
    convert :: QualStmt e -> Stmt
convert (Exts.QualStmt e
_ Stmt e
st) = forall a. ToStmt a => a -> Stmt
toStmt Stmt e
st
    convert QualStmt e
s                    = 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 (forall a. ToExp a => a -> Exp
toExp Exp l
e) (forall a. ToType a => a -> Type
toType Type l
t)
  toExp Exp l
e = 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 :: forall l. Alt l -> Match
toMatch (Exts.Alt l
_ Pat l
p Rhs l
rhs Maybe (Binds l)
ds) = Pat -> Body -> [Dec] -> Match
TH.Match (forall a. ToPat a => a -> Pat
toPat Pat l
p) (forall l. Rhs l -> Body
toBody Rhs l
rhs) (forall a. ToDecs a => a -> [Dec]
toDecs Maybe (Binds l)
ds)

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

toGuard :: Exts.GuardedRhs l -> (TH.Guard, TH.Exp)
toGuard :: forall l. GuardedRhs l -> (Guard, Exp)
toGuard (Exts.GuardedRhs l
_ [Stmt l]
stmts Exp l
e) = (Guard
g, forall a. ToExp a => a -> Exp
toExp Exp l
e)
  where
    g :: Guard
g = case forall a b. (a -> b) -> [a] -> [b]
map 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) = 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)  = forall a. ToDecs a => a -> [Dec]
toDecs [Decl l]
ds
  toDecs a :: Binds l
a@(Exts.IPBinds {}) = 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) = forall a. ToDecs a => a -> [Dec]
toDecs Decl l
d
  toDecs ClassDecl l
x                  = 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
_) = forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.UnkindedVar l
_ Name l
n) = forall a. ToName a => a -> Name
toName Name l
n

instance ToName TH.Name where
  toName :: Name -> Name
toName = forall a. a -> a
id

instance ToName (Compat.TyVarBndr_ flag) where
#if MIN_VERSION_template_haskell(2,17,0)
  toName :: TyVarBndr_ flag -> Name
toName (TH.PlainTV Name
n flag
_)    = Name
n
  toName (TH.KindedTV Name
n flag
_ Type
_) = Name
n
#else
  toName (TH.PlainTV n)      = n
  toName (TH.KindedTV n _)   = n
#endif

#if !MIN_VERSION_haskell_src_exts(1,21,0)
instance ToType (Exts.Kind l) where
  toType (Exts.KindStar _)     = TH.StarT
  toType (Exts.KindFn _ k1 k2) = toType k1 .->. toType k2
  toType (Exts.KindParen _ kp) = toType kp
  toType (Exts.KindVar _ n)    = TH.VarT (toName n)
  -- TODO LumiGuide:
  -- toType (Hs.KindVar _ n)
  --    | isCon (nameBase th_n) = ConT th_n
  --    | otherwise             = VarT th_n
  --  where
  --    th_n = toName n
  --
  --    isCon :: String -> Bool
  --    isCon (c:_) = isUpper c || c == ':'
  --    isCon _ = nonsense "toType" "empty kind variable name" n
  toType (Exts.KindApp _ k1 k2) = toType k1 `TH.AppT` toType k2
  toType (Exts.KindTuple _ ks) = foldr (\k pt -> pt `TH.AppT` toType k) (TH.TupleT $ length ks) ks
  toType (Exts.KindList _ k) = TH.ListT `TH.AppT` toType k
#endif

toKind :: Exts.Kind l -> TH.Kind
toKind :: forall l. Kind l -> Type
toKind = forall a. ToType a => a -> Type
toType

toTyVar :: Exts.TyVarBind l -> TyVarBndr_ ()
#if MIN_VERSION_template_haskell(2,17,0)
toTyVar :: forall l. TyVarBind l -> TyVarBndr_ ()
toTyVar (Exts.KindedVar l
_ Name l
n Kind l
k) = forall flag. Name -> flag -> Type -> TyVarBndr flag
TH.KindedTV (forall a. ToName a => a -> Name
toName Name l
n) () (forall l. Kind l -> Type
toKind Kind l
k)
toTyVar (Exts.UnkindedVar l
_ Name l
n) = forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV (forall a. ToName a => a -> Name
toName Name l
n) ()
#else
toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) (toKind k)
toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n)
#endif

#if MIN_VERSION_template_haskell(2,17,0)
toTyVarSpec :: TyVarBndr_ () -> TH.TyVarBndrSpec
toTyVarSpec :: TyVarBndr_ () -> TyVarBndrSpec
toTyVarSpec (TH.KindedTV Name
n () Type
k) = forall flag. Name -> flag -> Type -> TyVarBndr flag
TH.KindedTV Name
n Specificity
TH.SpecifiedSpec Type
k
toTyVarSpec (TH.PlainTV Name
n ())    = forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV Name
n Specificity
TH.SpecifiedSpec
#else
toTyVarSpec :: TyVarBndr_ flag -> TyVarBndr_ flag
toTyVarSpec = 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) = [TyVarBndrSpec] -> Cxt -> Type -> Type
TH.ForallT (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyVarBndr_ () -> TyVarBndrSpec
toTyVarSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. TyVarBind l -> TyVarBndr_ ()
toTyVar)) Maybe [TyVarBind l]
tvbM) (forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt) (forall a. ToType a => a -> Type
toType Type l
t)
  toType (Exts.TyFun l
_ Type l
a Type l
b) = forall a. ToType a => a -> Type
toType Type l
a Type -> Type -> 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` 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ [Type l]
ts) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 (forall a. ToType a => a -> Type
toType Type l
a) (forall a. ToType a => a -> Type
toType Type l
b)
  toType (Exts.TyVar l
_ Name l
n) = Name -> Type
TH.VarT (forall a. ToName a => a -> Name
toName Name l
n)
  toType (Exts.TyCon l
_ QName l
qn) = Name -> Type
TH.ConT (forall a. ToName a => a -> Name
toName QName l
qn)
  toType (Exts.TyParen l
_ Type l
t) = 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 (forall a. ToName a => a -> Name
toName QName l
o)) (forall a. ToType a => a -> Type
toType Type l
a)) (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 (forall a. ToType a => a -> Type
toType Type l
t) (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 forall a b. (a -> b) -> a -> b
$ Integer -> TyLit
TH.NumTyLit Integer
i
    Exts.PromotedString l
_ String
_ String
s -> TyLit -> Type
TH.LitT 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 forall a b. (a -> b) -> a -> b
$ forall a. ToName a => a -> Name
toName QName l
n
    Exts.PromotedList l
_ Bool
_q [Type l]
ts -> 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` 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 -> 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` forall a. ToType a => a -> Type
toType Type l
t) (Int -> Type
TH.PromotedTupleT forall a b. (a -> b) -> a -> b
$ 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` forall a. ToType a => a -> Type
toType Type l
t1 Type -> Type -> Type
`TH.AppT` forall a. ToType a => a -> Type
toType Type l
t2
  toType t :: Type l
t@Exts.TySplice{} = 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{} =
    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{} = forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toType" Type l
t
  toType Type l
t = 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 :: forall l. Type l -> StrictType
toStrictType (Exts.TyBang l
_ BangType l
s Unpackedness l
u Type l
t) = (SourceUnpackedness -> SourceStrictness -> Bang
TH.Bang (forall {l}. Unpackedness l -> SourceUnpackedness
toUnpack Unpackedness l
u) (forall {l}. BangType l -> SourceStrictness
toStrict BangType l
s), 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, 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) = 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) = forall a. ToPred a => a -> Type
toPred Asst l
asst
    toPred a :: Asst l
a@Exts.IParam{} = 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l. DerivStrategy l -> DerivStrategy
toDerivStrategy Maybe (DerivStrategy l)
strat) (forall a b. (a -> b) -> [a] -> [b]
map 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) = forall a. ToDerivClauses a => a -> [DerivClause]
toDerivClauses a
a

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


toDerivStrategy :: (Exts.DerivStrategy l) -> TH.DerivStrategy
toDerivStrategy :: forall l. 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 (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 = 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 (forall a. ToPat a => a -> Pat
toPat Pat l
p) (forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toStmt (Exts.Qualifier l
_ Exp l
e)     = Exp -> Stmt
TH.NoBindS (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 (forall a. ToDecs a => a -> [Dec]
toDecs Binds l
bnds)
  toStmt s :: Stmt l
s@Exts.RecStmt{}         = 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_ ()] -> Type -> Dec
TH.TySynD (forall a. ToName a => a -> Name
toName DeclHead l
h) (forall a. ToTyVars a => a -> [TyVarBndr_ ()]
toTyVars DeclHead l
h) (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_ ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD (forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt)
                             (forall a. ToName a => a -> Name
toName DeclHead l
h)
                             (forall a. ToTyVars a => a -> [TyVarBndr_ ()]
toTyVars DeclHead l
h)
                             forall a. Maybe a
Nothing
                             (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l. QualConDecl l -> Con
qualConDeclToCon [QualConDecl l]
qcds)
                             (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]
_   -> forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> String -> f e -> a
nonsense String
"toDec" (String
"newtype with " forall a. [a] -> [a] -> [a]
++
                                                              String
"wrong number of constructors") Decl l
a
                        in Cxt
-> Name
-> [TyVarBndr_ ()]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
TH.NewtypeD (forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt)
                                    (forall a. ToName a => a -> Name
toName DeclHead l
h)
                                    (forall a. ToTyVars a => a -> [TyVarBndr_ ()]
toTyVars DeclHead l
h)
                                    forall a. Maybe a
Nothing
                                    (forall l. QualConDecl l -> Con
qualConDeclToCon QualConDecl l
qcd)
                                    (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Type -> Dec
TH.SigD (forall a. ToType a => a -> Type
toType Type l
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName) [Name l]
ns
      in case [Dec]
xs of Dec
x:[Dec]
_ -> Dec
x; [] -> 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 forall a b. (a -> b) -> a -> b
$
    Name -> Inline -> RuleMatch -> Phases -> Pragma
TH.InlineP (forall a. ToName a => a -> Name
toName QName l
qn) Inline
TH.Inline RuleMatch
TH.ConLike (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 forall a b. (a -> b) -> a -> b
$
    Name -> Inline -> RuleMatch -> Phases -> Pragma
TH.InlineP (forall a. ToName a => a -> Name
toName QName l
qn) Inline
inline RuleMatch
TH.FunLike (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 forall a b. (a -> b) -> a -> b
$ Name
-> [TyVarBndr_ ()]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TH.TypeFamilyHead (forall a. ToName a => a -> Name
toName DeclHead l
h)
                                       (forall a. ToTyVars a => a -> [TyVarBndr_ ()]
toTyVars DeclHead l
h)
                                       (forall b a. b -> (a -> b) -> Maybe a -> b
maybe FamilyResultSig
TH.NoSig Type -> FamilyResultSig
TH.KindSig forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToMaybeKind a => a -> Maybe Type
toMaybeKind forall a b. (a -> b) -> a -> b
$ Maybe (ResultSig l)
sig)
                                       (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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_ ()] -> Maybe Type -> Dec
TH.DataFamilyD (forall a. ToName a => a -> Name
toName DeclHead l
h) (forall a. ToTyVars a => a -> [TyVarBndr_ ()]
toTyVars DeclHead l
h) (forall a. ToMaybeKind a => a -> Maybe Type
toMaybeKind Maybe (ResultSig l)
sig)

  toDec _a :: Decl l
_a@(Exts.FunBind l
_ [Match l]
mtchs)                           = 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 (forall a. ToPat a => a -> Pat
toPat Pat l
p)
                                                              (forall l. Rhs l -> Body
hsRhsToBody Rhs l
rhs)
                                                              (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]
_) =
    forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH String
"toDec" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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
    forall a. Maybe a
Nothing
    (forall a. ToCxt a => a -> Cxt
toCxt InstRule l
irule)
    (forall a. ToType a => a -> Type
toType InstRule l
irule)
    (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_ ()] -> [FunDep] -> [Dec] -> Dec
TH.ClassD
    (forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt)
    (forall a. ToName a => a -> Name
toName DeclHead l
h)
    (forall a. ToTyVars a => a -> [TyVarBndr_ ()]
toTyVars DeclHead l
h)
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {l}. FunDep l -> FunDep
toFunDep [FunDep l]
fds)
    (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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToName a => a -> Name
toName [Name l]
ls) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 (forall {l}. Annotation l -> AnnTarget
target Annotation l
ann) (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 (forall a. ToName a => a -> Name
toName Name l
n)
      target (Exts.TypeAnn l
_ Name l
n Exp l
_) = Name -> AnnTarget
TH.TypeAnnotation (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)     = forall a. ToExp a => a -> Exp
toExp Exp l
e
      expann (Exts.TypeAnn l
_ Name l
_ Exp l
e) = forall a. ToExp a => a -> Exp
toExp Exp l
e
      expann (Exts.ModuleAnn l
_ Exp l
e) = forall a. ToExp a => a -> Exp
toExp Exp l
e

  toDec Decl l
x = 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)  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. Kind l -> Type
toKind Kind l
k
    toMaybeKind (Exts.TyVarSig l
_ TyVarBind l
_) = forall a. Maybe a
Nothing

instance ToMaybeKind a => ToMaybeKind (Maybe a) where
    toMaybeKind :: Maybe a -> Maybe Type
toMaybeKind Maybe a
Nothing  = forall a. Maybe a
Nothing
    toMaybeKind (Just a
a) = 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 (forall a. ToName a => a -> Name
toName Name l
n) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToName a => a -> Name
toName [Name l]
ns)

transAct :: Maybe (Exts.Activation l) -> TH.Phases
transAct :: forall l. 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)     = forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.DHInfix l
_ TyVarBind l
_ Name l
n) = forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.DHParen l
_ DeclHead l
h)   = forall a. ToName a => a -> Name
toName DeclHead l
h
  toName (Exts.DHApp l
_ DeclHead l
h TyVarBind l
_)   = forall a. ToName a => a -> Name
toName DeclHead l
h

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

instance ToNames a => ToNames (Maybe a) where
  toNames :: Maybe a -> [Name]
toNames Maybe a
Nothing  = []
  toNames (Just a
a) = 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) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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)            = 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) = 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)     = [forall a. ToName a => a -> Name
toName QName l
n]
  toNames (Exts.IHInfix l
_ Type l
_ QName l
n) = [forall a. ToName a => a -> Name
toName QName l
n]
  toNames (Exts.IHParen l
_ InstHead l
h)   = forall a. ToNames a => a -> [Name]
toNames InstHead l
h
  toNames (Exts.IHApp l
_ InstHead l
h Type l
_)   = 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
_) = forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt
  toCxt (Exts.IParen l
_ InstRule l
irule)  = 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' -> [forall a. ToPred a => a -> Type
toPred Asst l
x']
              Exts.CxTuple l
_ [Asst l]
xs  -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) = 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)  = forall a. ToType a => a -> Type
toType InstHead l
h
    toType (Exts.IParen l
_ InstRule l
irule) = 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)       = 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 (forall a. ToType a => a -> Type
toType Type l
typ) (forall a. ToType a => a -> Type
toType QName l
qn)
    toType (Exts.IHParen l
_ InstHead l
hd)     = 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 (forall a. ToType a => a -> Type
toType InstHead l
hd) (forall a. ToType a => a -> Type
toType Type l
typ)

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

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

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

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

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

conDeclToCon :: Exts.ConDecl l -> TH.Con
conDeclToCon :: forall l. ConDecl l -> Con
conDeclToCon (Exts.ConDecl l
_ Name l
n [Type l]
tys)
  = Name -> [StrictType] -> Con
TH.NormalC (forall a. ToName a => a -> Name
toName Name l
n) (forall a b. (a -> b) -> [a] -> [b]
map forall l. Type l -> StrictType
toStrictType [Type l]
tys)
conDeclToCon (Exts.RecDecl l
_ Name l
n [FieldDecl l]
fieldDecls)
  = Name -> [VarBangType] -> Con
TH.RecC (forall a. ToName a => a -> Name
toName Name l
n) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall l. FieldDecl l -> [VarBangType]
convField [FieldDecl l]
fieldDecls)
  where
    convField :: Exts.FieldDecl l -> [TH.VarStrictType]
    convField :: forall l. FieldDecl l -> [VarBangType]
convField (Exts.FieldDecl l
_ [Name l]
ns Type l
t) =
      let (Bang
strict, Type
ty) = forall l. Type l -> StrictType
toStrictType Type l
t
      in forall a b. (a -> b) -> [a] -> [b]
map (\Name l
n' -> (forall a. ToName a => a -> Name
toName Name l
n', Bang
strict, Type
ty)) [Name l]
ns
conDeclToCon ConDecl l
h = 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 :: forall l. [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 (forall a. ToName a => a -> Name
toName Name l
n) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 (forall a. ToName a => a -> Name
toName Name l
n) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l. Match l -> Clause
hsMatchToClause [Match l]
xs)


hsMatchToClause :: Exts.Match l -> TH.Clause
hsMatchToClause :: forall l. 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
                                                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
                                                (forall l. Rhs l -> Body
hsRhsToBody Rhs l
rhs)
                                                (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
                                                        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToPat a => a -> Pat
toPat (Pat l
pforall a. a -> [a] -> [a]
:[Pat l]
ps))
                                                        (forall l. Rhs l -> Body
hsRhsToBody Rhs l
rhs)
                                                        (forall a. ToDecs a => a -> [Dec]
toDecs Maybe (Binds l)
bnds)



hsRhsToBody :: Exts.Rhs l -> TH.Body
hsRhsToBody :: forall l. Rhs l -> Body
hsRhsToBody (Exts.UnGuardedRhs l
_ Exp l
e) = Exp -> Body
TH.NormalB (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               = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Body -> [(Guard, Exp)]
fromGuardedB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. GuardedRhs l -> Body
hsGuardedRhsToBody)
     forall a b. (a -> b) -> a -> b
$ [GuardedRhs l]
hsgrhs


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



hsStmtToGuard :: Exts.Stmt l -> TH.Guard
hsStmtToGuard :: forall l. Stmt l -> Guard
hsStmtToGuard (Exts.Generator l
_ Pat l
p Exp l
e) = [Stmt] -> Guard
TH.PatG [Pat -> Exp -> Stmt
TH.BindS (forall a. ToPat a => a -> Pat
toPat Pat l
p) (forall a. ToExp a => a -> Exp
toExp Exp l
e)]
hsStmtToGuard (Exts.Qualifier l
_ Exp l
e)   = Exp -> Guard
TH.NormalG (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 (forall a. ToDecs a => a -> [Dec]
toDecs Binds l
bs)]
hsStmtToGuard Stmt l
h                      = 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) = forall a. ToDecs a => a -> [Dec]
toDecs Decl l
decl
  toDecs InstDecl l
d                     = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Type -> Dec
TH.SigD (forall a. ToType a => a -> Type
toType Type l
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
      forall a. ToDecs a => a -> [Dec]
toDecs (forall l. l -> Assoc l -> Maybe Int -> [Op l] -> Decl l
Exts.InfixDecl l
l Assoc l
assoc (forall a. a -> Maybe a
Just Int
9) [Op l]
ops)
  toDecs (Exts.InfixDecl l
_ Assoc l
assoc (Just Int
fixity) [Op l]
ops) =
    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) (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 = [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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. ToDecs a => a -> [Dec]
toDecs [a]
a