{-# 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
) 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 qualified Language.Haskell.TH.Lib      as TH
import qualified Language.Haskell.TH.Syntax   as TH

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

#if MIN_VERSION_template_haskell(2,17,0)
type TyVarBndr_ flag = TH.TyVarBndr flag
#else
type TyVarBndr_ flag = TH.TyVarBndr
#endif

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

#if MIN_VERSION_template_haskell(2,12,0)
type DerivClause = TH.DerivClause
#elif MIN_VERSION_template_haskell(2,11,0)
type DerivClause = TH.Pred
#else
type DerivClause = TH.Name
#endif

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
TH.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)
  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)
#if MIN_VERSION_template_haskell(2,12,0)
  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)
#else
  toExp (Exts.App _ _ e@Exts.TypeApp{}) = noTHyet "toExp" "2.12.0" e
#endif
  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 (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 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
pt -> 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
#if MIN_VERSION_template_haskell(2,11,0)
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)
#else
-- TODO: what is this comment? Outdated?
-- TyBang l (BangType l) (Unpackedness l) (Type l)
-- data BangType l = BangedTy l        | LazyTy l | NoStrictAnnot l
-- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l
toStrictType (Exts.TyBang _ b u t) = (toStrict b u, toType t)
    where
      toStrict :: Exts.BangType l -> Exts.Unpackedness l -> TH.Strict
      toStrict (Exts.BangedTy _) _ = TH.IsStrict
      toStrict _ (Exts.Unpack _)   = TH.Unpacked
      toStrict _ _                 = TH.NotStrict
toStrictType x = (TH.NotStrict, toType x)
#endif

(.->.) :: 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_template_haskell(2,12,0)
#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
#elif MIN_VERSION_template_haskell(2,11,0)
#if MIN_VERSION_haskell_src_exts(1,20,0)
  toDerivClauses (Exts.Deriving _ _ irules) = map toType irules
#else
  toDerivClauses (Exts.Deriving _ irules) = map toType irules
#endif
#else
-- template-haskell < 2.11
#if MIN_VERSION_haskell_src_exts(1,20,0)
  toDerivClauses (Exts.Deriving _ _ irules) = concatMap toNames irules
#else
  toDerivClauses (Exts.Deriving _ irules) = concatMap toNames irules
#endif
#endif

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


#if MIN_VERSION_template_haskell(2,12,0) && MIN_VERSION_haskell_src_exts(1,20,0)
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)
#if 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
#endif

#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)
#if MIN_VERSION_template_haskell(2,11,0)
                             Maybe Type
forall a. Maybe a
Nothing
#endif
                             ((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)
#if MIN_VERSION_template_haskell(2,11,0)
                                    Maybe Type
forall a. Maybe a
Nothing
#endif
                                    (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

#if MIN_VERSION_template_haskell(2,11,0)
  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)
#else
  toDec (Exts.TypeFamDecl _ h sig inj)
    = TH.FamilyD TH.TypeFam (toName h) (toTyVars h) (toMaybeKind sig)
  toDec (Exts.DataFamDecl _ _ h sig)
    = TH.FamilyD TH.DataFam (toName h) (toTyVars h) (toMaybeKind sig)
#endif

  toDec _a :: 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.
#if MIN_VERSION_template_haskell(2,11,0)
  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)
#else
  toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD
    (toCxt irule)
    (toType irule)
    (toDecs ids)
#endif

  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 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

#if MIN_VERSION_template_haskell(2,11,0)
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)
#endif

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

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