{-# 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 = "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 fun :: String
fun thing :: 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
fun,
  ": 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 fun :: String
fun minVersion :: String
minVersion thing :: 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
fun,
  ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")",
  " 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 fun :: String
fun thing :: 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
fun,
  ": 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 fun :: String
fun inparticular :: String
inparticular thing :: 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
fun,
  ": nonsensical: ", String
inparticular, ": ", 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 = Just . toExp
#else
toTupEl :: ToExp a => a -> TH.Exp
toTupEl :: a -> Exp
toTupEl = a -> Exp
forall a. ToExp a => a -> Exp
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
a,b :: b
b) = [Exp] -> Exp
TH.TupE [a -> Exp
forall a. ToExp a => a -> Exp
toTupEl a
a, b -> Exp
forall a. ToExp a => a -> Exp
toTupEl b
b]
instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where
  toExp :: (a, b, c) -> Exp
toExp (a :: a
a,b :: b
b,c :: c
c) = [Exp] -> Exp
TH.TupE [a -> Exp
forall a. ToExp a => a -> Exp
toTupEl a
a, b -> Exp
forall a. ToExp a => a -> Exp
toTupEl b
b, c -> Exp
forall a. ToExp a => a -> 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
a,b :: b
b,c :: c
c,d :: d
d) = [Exp] -> Exp
TH.TupE [a -> Exp
forall a. ToExp a => a -> Exp
toTupEl a
a, b -> Exp
forall a. ToExp a => a -> Exp
toTupEl b
b, c -> Exp
forall a. ToExp a => a -> Exp
toTupEl c
c, d -> Exp
forall a. ToExp a => a -> 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
a,b :: 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
a,b :: b
b,c :: 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
a,b :: b
b,c :: c
c,d :: 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 _ s :: String
s)  = String -> Name
forall a. ToName a => a -> Name
toName String
s
  toName (Exts.Symbol _ s :: 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 _) = String -> Name
TH.mkName "()" -- TODO LumiGuide: '()
  toName (Exts.ListCon _) = ''[] -- Parser only uses this in types -- TODO LumiGuide: '[]
  toName (Exts.FunCon _)  = ''(->)
  toName (Exts.TupleCon _ _ n :: 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 ["(",Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) ',',")"]
    -- TODO LumiGuide:
    -- .
    -- .| n<2 = '()
    -- .| otherwise =
    -- .  let x = maybe [] (++".") (nameModule '(,))
    -- .  in TH.mkName . concat $ x : ["(",replicate (n-1) ',',")"]
  toName (Exts.Cons _)    = '(:)
  toName h :: SpecialCon l
h = String -> SpecialCon l -> Name
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo "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 _ (Exts.ModuleName _ []) n :: Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.Qual _ (Exts.ModuleName _ m :: String
m) n :: 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
n']
  toName (Exts.UnQual _ n :: Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.Special _ s :: 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   _ qn :: QName l
qn) = QName l -> Name
forall a. ToName a => a -> Name
toName QName l
qn
  toName (Exts.UnpromotedName _ qn :: 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 _ n :: Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.ConOp _ n :: 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 _ a :: Char
a _) = Char -> Lit
TH.CharL Char
a
  toLit (Exts.String _ a :: String
a _) = String -> Lit
TH.StringL String
a
  toLit (Exts.Int _ a :: Integer
a _) = Integer -> Lit
TH.IntegerL Integer
a
  toLit (Exts.Frac _ a :: Rational
a _) = 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 "toLit" Literal l
l
  toLit (Exts.PrimString _ a :: String
a _) = [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 _ a :: Integer
a _) = Integer -> Lit
TH.IntPrimL Integer
a
  toLit (Exts.PrimFloat _ a :: Rational
a _) = Rational -> Lit
TH.FloatPrimL Rational
a
  toLit (Exts.PrimDouble _ a :: Rational
a _) = Rational -> Lit
TH.DoublePrimL Rational
a
  toLit (Exts.PrimWord _ a :: Integer
a _) = Integer -> Lit
TH.WordPrimL Integer
a


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

-- * ToPat HsPat

instance ToPat (Exts.Pat l) where
  toPat :: Pat l -> Pat
toPat (Exts.PVar _ n :: Name l
n)
    = Name -> Pat
TH.VarP (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n)
  toPat (Exts.PLit _ (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 _ (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 z :: Integer
z      -> Integer -> Lit
TH.IntegerL (Integer -> Integer
forall a. Num a => a -> a
negate Integer
z)
    TH.RationalL q :: Rational
q     -> Rational -> Lit
TH.RationalL (Rational -> Rational
forall a. Num a => a -> a
negate Rational
q)
    TH.IntPrimL z' :: Integer
z'     -> Integer -> Lit
TH.IntPrimL (Integer -> Integer
forall a. Num a => a -> a
negate Integer
z')
    TH.FloatPrimL r' :: Rational
r'   -> Rational -> Lit
TH.FloatPrimL (Rational -> Rational
forall a. Num a => a -> a
negate Rational
r')
    TH.DoublePrimL r'' :: Rational
r'' -> Rational -> Lit
TH.DoublePrimL (Rational -> Rational
forall a. Num a => a -> a
negate Rational
r'')
    _                  -> String -> String -> Literal l -> Lit
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> String -> f e -> a
nonsense "toPat" "negating wrong kind of literal" Literal l
l
  toPat (Exts.PInfixApp _ p :: Pat l
p n :: QName l
n q :: 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 _ n :: QName l
n ps :: [Pat l]
ps) = Name -> [Pat] -> Pat
Compat.conP (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n) ((Pat l -> Pat) -> [Pat l] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat [Pat l]
ps)
  toPat (Exts.PTuple _ Exts.Boxed ps :: [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 _ Exts.Unboxed ps :: [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 _ ps :: [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 _ p :: 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 _ n :: QName l
n pfs :: [PatField l]
pfs) = let toFieldPat :: PatField e -> (Name, Pat)
toFieldPat (Exts.PFieldPat _ n' :: QName e
n' p :: 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 h :: PatField e
h = String -> PatField e -> (Name, Pat)
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo "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 _ n :: Name l
n p :: 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 _) = Pat
TH.WildP
  toPat (Exts.PIrrPat _ p :: Pat l
p) = Pat -> Pat
TH.TildeP (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p)
  toPat (Exts.PatTypeSig _ p :: Pat l
p t :: 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 _ e :: Exp l
e p :: 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 "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 "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 "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 "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 "toPat" Pat l
p
  toPat (Exts.PBangPat _ p :: Pat l
p) = Pat -> Pat
TH.BangP (Pat l -> Pat
forall a. ToPat a => a -> Pat
toPat Pat l
p)
  toPat p :: Pat l
p = String -> Pat l -> Pat
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo "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 _ n :: QName l
n) = Name -> Exp
TH.VarE (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n)
  toExp (Exts.QConOp _ n :: 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 _ n :: QName l
n e :: 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 h :: FieldUpdate l
h                        = String -> FieldUpdate l -> FieldExp
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo "toFieldExp" FieldUpdate l
h




instance ToExp (Exts.Exp l) where
  toExp :: Exp l -> Exp
toExp (Exts.Var _ n :: 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 "toExp" Exp l
e
  toExp (Exts.Con _ n :: QName l
n)                 = Name -> Exp
TH.ConE (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n)
  toExp (Exts.Lit _ l :: Literal l
l)                 = Lit -> Exp
TH.LitE (Literal l -> Lit
forall a. ToLit a => a -> Lit
toLit Literal l
l)
#if MIN_VERSION_template_haskell(2,13,0)
  toExp (Exts.OverloadedLabel _ s :: String
s)     = String -> Exp
TH.LabelE String
s
#endif
  toExp (Exts.InfixApp _ e :: Exp l
e o :: QOp l
o f :: Exp l
f)        = Exp -> Exp -> Exp -> Exp
TH.UInfixE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (QOp l -> Exp
forall a. ToExp a => a -> Exp
toExp QOp l
o) (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
f)
  toExp (Exts.App _ e :: Exp l
e (Exts.TypeApp _ t :: Type l
t)) = Exp -> Type -> Exp
TH.AppTypeE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e) (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t)
  toExp (Exts.App _ e :: Exp l
e f :: 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 _ e :: 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 _ ps :: [Pat l]
ps e :: 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 _ bs :: Binds l
bs e :: 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 _ a :: Exp l
a b :: Exp l
b c :: 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 _ ifs :: [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 _ e :: Exp l
e alts :: [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 _ ss :: [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 "toExp" Exp l
e
  toExp (Exts.Tuple _ Exts.Boxed xs :: [Exp l]
xs)   = [Exp] -> Exp
TH.TupE ((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
toTupEl [Exp l]
xs)
  toExp (Exts.Tuple _ Exts.Unboxed xs :: [Exp l]
xs) = [Exp] -> Exp
TH.UnboxedTupE ((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
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 "toExp" Exp l
e
  toExp (Exts.List _ xs :: [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 _ e :: Exp l
e)               = Exp -> Exp
TH.ParensE (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
  toExp (Exts.LeftSection _ e :: Exp l
e o :: 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 _ o :: QOp l
o f :: 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 _ n :: QName l
n xs :: [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 _ e :: Exp l
e xs :: [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 _ e :: 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 _ e :: Exp l
e f :: 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 _ e :: Exp l
e f :: 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 _ e :: Exp l
e f :: Exp l
f g :: 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 _ e :: Exp l
e ss :: [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 _ st :: Stmt e
st) = Stmt e -> Stmt
forall a. ToStmt a => a -> Stmt
toStmt Stmt e
st
    convert s :: QualStmt e
s                    = String -> QualStmt e -> Stmt
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH "toExp ListComp" QualStmt e
s
  toExp (Exts.ExpTypeSig _ e :: Exp l
e t :: 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 e :: Exp l
e = String -> Exp l -> Exp
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo "toExp" Exp l
e


toMatch :: Exts.Alt l -> TH.Match
toMatch :: Alt l -> Match
toMatch (Exts.Alt _ p :: Pat l
p rhs :: Rhs l
rhs ds :: 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 _ e :: 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 _ rhss :: [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 _ stmts :: [Stmt l]
stmts e :: 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 x :: Exp
x] -> Exp -> Guard
TH.NormalG Exp
x
      xs :: [Stmt]
xs             -> [Stmt] -> Guard
TH.PatG [Stmt]
xs

instance ToDecs a => ToDecs (Maybe a) where
    toDecs :: Maybe a -> [Dec]
toDecs Nothing  = []
    toDecs (Just a :: 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 _ ds :: [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 "ToDecs Exts.Binds" Binds l
a

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

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

-- * ToLoc SrcLoc

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

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

-- * ToType HsType

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

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

instance ToName (Compat.TyVarBndr_ flag) where
#if MIN_VERSION_template_haskell(2,17,0)
  toName (TH.PlainTV n _)    = n
  toName (TH.KindedTV n _ _) = n
#else
  toName :: TyVarBndr_ flag -> Name
toName (TH.PlainTV n :: Name
n)      = Name
n
  toName (TH.KindedTV n :: Name
n _)   = 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 _ n :: Name l
n k :: 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 _ n :: 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 _ tvbM :: Maybe [TyVarBind l]
tvbM cxt :: Maybe (Context l)
cxt t :: 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 _ a :: Type l
a b :: 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 _ t :: 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 _ b :: Boxed
b ts :: [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
      Exts.Boxed   -> Int -> Type
TH.TupleT
      Exts.Unboxed -> Int -> Type
TH.UnboxedTupleT
  toType (Exts.TyApp _ a :: Type l
a b :: 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 _ n :: Name l
n) = Name -> Type
TH.VarT (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n)
  toType (Exts.TyCon _ qn :: QName l
qn) = Name -> Type
TH.ConT (QName l -> Name
forall a. ToName a => a -> Name
toName QName l
qn)
  toType (Exts.TyParen _ t :: 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 _ a :: Type l
a (Exts.UnpromotedName _ o :: QName l
o) b :: 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 _ t :: Type l
t k :: 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 _ p :: Promoted l
p) = case Promoted l
p of
    Exts.PromotedInteger _ i :: Integer
i _ -> TyLit -> Type
TH.LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ Integer -> TyLit
TH.NumTyLit Integer
i
    Exts.PromotedString _ _ s :: 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 _ _q :: Bool
_q n :: 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 _ _q :: Bool
_q ts :: [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 (\t :: Type l
t pl :: 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 _ ts :: [Type l]
ts -> (Type -> Type l -> Type) -> Type -> [Type l] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\pt :: Type
pt t :: Type l
t -> Type
pt Type -> Type -> Type
`TH.AppT` Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t) (Int -> Type
TH.PromotedTupleT (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ [Type l] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type l]
ts) [Type l]
ts
    Exts.PromotedUnit _ -> Name -> Type
TH.PromotedT ''()
  toType (Exts.TyEquals _ t1 :: Type l
t1 t2 :: 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 "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 "toType" "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 "toType" Type l
t
  toType t :: Type l
t = String -> Type l -> Type
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo "toType" Type l
t
  -- TODO
  -- toType (Exts.TyUnboxedSum _ _)
  -- toType (Exts.TyParArray _ _)
  -- toType (Exts.TyInfix _ _ (Exts.PromotedName _ _) _)

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

(.->.) :: TH.Type -> TH.Type -> TH.Type
a :: Type
a .->. :: Type -> Type -> Type
.->. b :: 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 _ t :: 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 _ asst :: 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 "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 _ strat :: Maybe (DerivStrategy l)
strat irules :: [InstRule l]
irules) = [Maybe DerivStrategy -> Cxt -> DerivClause
TH.DerivClause ((DerivStrategy l -> DerivStrategy)
-> Maybe (DerivStrategy l) -> Maybe DerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DerivStrategy l -> DerivStrategy
forall l. DerivStrategy l -> DerivStrategy
toDerivStrategy Maybe (DerivStrategy l)
strat) ((InstRule l -> Type) -> [InstRule l] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map InstRule l -> Type
forall a. ToType a => a -> Type
toType [InstRule l]
irules)]
#else
  toDerivClauses (Exts.Deriving _ irules) = [TH.DerivClause Nothing (map toType irules)]
#endif

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

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


toDerivStrategy :: (Exts.DerivStrategy l) -> TH.DerivStrategy
toDerivStrategy :: DerivStrategy l -> DerivStrategy
toDerivStrategy (Exts.DerivStock _)    = DerivStrategy
TH.StockStrategy
toDerivStrategy (Exts.DerivAnyclass _) = DerivStrategy
TH.AnyclassStrategy
toDerivStrategy (Exts.DerivNewtype _)  = DerivStrategy
TH.NewtypeStrategy
#if MIN_VERSION_haskell_src_exts(1,21,0) && MIN_VERSION_template_haskell(2,14,0)
toDerivStrategy (Exts.DerivVia _ t :: Type l
t)    = Type -> DerivStrategy
TH.ViaStrategy (Type l -> Type
forall a. ToType a => a -> Type
toType Type l
t)
#else
toDerivStrategy d@Exts.DerivVia{}      = noTHyet "toDerivStrategy" "2.14" d
#endif


-- TODO LumiGuide
-- instance ToCxt (Hs.Deriving l) where
-- #if MIN_VERSION_haskell_src_exts(1,20,1)
--   toCxt (Hs.Deriving _ _ rule) = toCxt rule
-- #else
--   toCxt (Hs.Deriving _   rule) = toCxt rule
-- #endif

-- instance ToCxt [Hs.InstRule l] where
--   toCxt = concatMap toCxt

-- instance ToCxt a => ToCxt (Maybe a) where
--     toCxt Nothing = []
--     toCxt (Just a) = toCxt a


foldAppT :: TH.Type -> [TH.Type] -> TH.Type
foldAppT :: Type -> Cxt -> Type
foldAppT t :: Type
t ts :: 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 _ p :: Pat l
p e :: 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 _ e :: 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 _ bnds :: 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 "toStmt" Stmt l
s


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

-- * ToDec HsDecl

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

  -- This type-signature conversion is just wrong.
  -- Type variables need to be dealt with. /Jonas
  toDec _a :: Decl l
_a@(Exts.TypeSig _ ns :: [Name l]
ns t :: 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 x :: Dec
x:_ -> Dec
x; [] -> String -> Dec
forall a. HasCallStack => String -> a
error "toDec: malformed TypeSig!"

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

  toDec (Exts.TypeFamDecl _ h :: DeclHead l
h sig :: Maybe (ResultSig l)
sig inj :: 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 _ _ h :: DeclHead l
h sig :: Maybe (ResultSig l)
sig)
    = Name -> [TyVarBndr_ flag] -> Maybe Type -> Dec
TH.DataFamilyD (DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h) (DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h) (Maybe (ResultSig l) -> Maybe Type
forall a. ToMaybeKind a => a -> Maybe Type
toMaybeKind Maybe (ResultSig l)
sig)

  toDec _a :: Decl l
_a@(Exts.FunBind _ mtchs :: [Match l]
mtchs)                           = [Match l] -> Dec
forall l. [Match l] -> Dec
hsMatchesToFunD [Match l]
mtchs
  toDec (Exts.PatBind _ p :: Pat l
p rhs :: Rhs l
rhs bnds :: 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 _ (Just overlap :: Overlap l
overlap) _ _) =
    String -> (Overlap (), Decl l) -> Dec
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
noTH "toDec" ((l -> ()) -> Overlap l -> Overlap ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> l -> ()
forall a b. a -> b -> a
const ()) Overlap l
overlap, Decl l
i)

  -- the 'vars' bit seems to be for: instance forall a. C (T a) where ...
  -- TH's own parser seems to flat-out ignore them, and honestly I can't see
  -- that it's obviously wrong to do so.
  toDec (Exts.InstDecl _ Nothing irule :: InstRule l
irule ids :: Maybe [InstDecl l]
ids) = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
TH.InstanceD
    Maybe Overlap
forall a. Maybe a
Nothing
    (InstRule l -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt InstRule l
irule)
    (InstRule l -> Type
forall a. ToType a => a -> Type
toType InstRule l
irule)
    (Maybe [InstDecl l] -> [Dec]
forall a. ToDecs a => a -> [Dec]
toDecs Maybe [InstDecl l]
ids)

  toDec (Exts.ClassDecl _ cxt :: Maybe (Context l)
cxt h :: DeclHead l
h fds :: [FunDep l]
fds decls :: 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 _ ls :: [Name l]
ls rs :: [Name l]
rs) = [Name] -> [Name] -> FunDep
TH.FunDep ((Name l -> Name) -> [Name l] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name l -> Name
forall a. ToName a => a -> Name
toName [Name l]
ls) ((Name l -> Name) -> [Name l] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name l -> Name
forall a. ToName a => a -> Name
toName [Name l]
rs)

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

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

instance ToMaybeKind (Exts.ResultSig l) where
    toMaybeKind :: ResultSig l -> Maybe Type
toMaybeKind (Exts.KindSig _ k :: 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 _ _) = Maybe Type
forall a. Maybe a
Nothing

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

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

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

instance ToName (Exts.DeclHead l) where
  toName :: DeclHead l -> Name
toName (Exts.DHead _ n :: Name l
n)     = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.DHInfix _ _ n :: Name l
n) = Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n
  toName (Exts.DHParen _ h :: DeclHead l
h)   = DeclHead l -> Name
forall a. ToName a => a -> Name
toName DeclHead l
h
  toName (Exts.DHApp _ h :: DeclHead l
h _)   = 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 _ _)       = []
  toTyVars (Exts.DHParen _ h :: DeclHead l
h)     = DeclHead l -> [TyVarBndr_ flag]
forall a. ToTyVars a => a -> [TyVarBndr_ flag]
toTyVars DeclHead l
h
  toTyVars (Exts.DHInfix _ tvb :: TyVarBind l
tvb _) = [TyVarBind l -> TyVarBndr_ flag
forall l. TyVarBind l -> TyVarBndr_ flag
toTyVar TyVarBind l
tvb]
  toTyVars (Exts.DHApp _ h :: DeclHead l
h tvb :: 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 Nothing  = []
  toNames (Just a :: 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 _ _ irules :: [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 _ irule :: InstRule l
irule)            = InstRule l -> [Name]
forall a. ToNames a => a -> [Name]
toNames InstRule l
irule
  toNames (Exts.IRule _ _mtvbs :: Maybe [TyVarBind l]
_mtvbs _mcxt :: Maybe (Context l)
_mcxt mihd :: 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 _ n :: QName l
n)     = [QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n]
  toNames (Exts.IHInfix _ _ n :: QName l
n) = [QName l -> Name
forall a. ToName a => a -> Name
toName QName l
n]
  toNames (Exts.IHParen _ h :: InstHead l
h)   = InstHead l -> [Name]
forall a. ToNames a => a -> [Name]
toNames InstHead l
h
  toNames (Exts.IHApp _ h :: InstHead l
h _)   = 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 _ _ cxt :: Maybe (Context l)
cxt _) = Maybe (Context l) -> Cxt
forall a. ToCxt a => a -> Cxt
toCxt Maybe (Context l)
cxt
  toCxt (Exts.IParen _ irule :: 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 x :: Context l
x = case Context l
x of
              Exts.CxEmpty _     -> []
              Exts.CxSingle _ x' :: Asst l
x' -> [Asst l -> Type
forall a. ToPred a => a -> Type
toPred Asst l
x']
              Exts.CxTuple _ xs :: [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 Nothing  = []
    toCxt (Just a :: 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 _ _ _ h :: InstHead l
h)  = InstHead l -> Type
forall a. ToType a => a -> Type
toType InstHead l
h
    toType (Exts.IParen _ irule :: 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 _ qn :: QName l
qn)       = QName l -> Type
forall a. ToType a => a -> Type
toType QName l
qn
    toType (Exts.IHInfix _ typ :: Type l
typ qn :: 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 _ hd :: InstHead l
hd)     = InstHead l -> Type
forall a. ToType a => a -> Type
toType InstHead l
hd
    toType (Exts.IHApp _ hd :: InstHead l
hd typ :: 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 _ Nothing Nothing cdecl :: ConDecl l
cdecl) = ConDecl l -> Con
forall l. ConDecl l -> Con
conDeclToCon ConDecl l
cdecl
qualConDeclToCon (Exts.QualConDecl _ ns :: Maybe [TyVarBind l]
ns cxt :: Maybe (Context l)
cxt cdecl :: 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 Nothing  = []
  toTyVars (Just a :: 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 tvb :: 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 _ n :: Name l
n tys :: [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 _ n :: Name l
n fieldDecls :: [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 _ ns :: [Name l]
ns t :: Type l
t) =
      let (strict :: Bang
strict, ty :: 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 (\n' :: Name l
n' -> (Name l -> Name
forall a. ToName a => a -> Name
toName Name l
n', Bang
strict, Type
ty)) [Name l]
ns
conDeclToCon h :: ConDecl l
h = String -> ConDecl l -> Con
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo "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 _ n :: Name l
n _ _ _ : _) = 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 _ _ n :: Name l
n _ _ _ : _) = 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 _ _ ps :: [Pat l]
ps rhs :: Rhs l
rhs bnds :: 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 _ p :: Pat l
p _ ps :: [Pat l]
ps rhs :: Rhs l
rhs bnds :: 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 _ e :: Exp l
e) = Exp -> Body
TH.NormalB (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
hsRhsToBody (Exts.GuardedRhss _ hsgrhs :: [GuardedRhs l]
hsgrhs) =
  let fromGuardedB :: Body -> [(Guard, Exp)]
fromGuardedB (TH.GuardedB a :: [(Guard, Exp)]
a) = [(Guard, Exp)]
a
      fromGuardedB h :: Body
h               = String -> [Body] -> [(Guard, Exp)]
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo "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 _ [] e :: Exp l
e)  = Exp -> Body
TH.NormalB (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
hsGuardedRhsToBody (Exts.GuardedRhs _ [s :: Stmt l
s] e :: 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 _ ss :: [Stmt l]
ss e :: 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
                                                   (pgs :: [[Stmt]]
pgs,ngs :: [Guard]
ngs) = [([Stmt], Guard)] -> ([[Stmt]], [Guard])
forall a b. [(a, b)] -> ([a], [b])
unzip [([Stmt]
p,Guard
n)
                                                                     | (TH.PatG p :: [Stmt]
p) <- [Guard]
ss'
                                                                     , n :: Guard
n@(TH.NormalG _) <- [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 _ p :: Pat l
p e :: 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 _ e :: Exp l
e)   = Exp -> Guard
TH.NormalG (Exp l -> Exp
forall a. ToExp a => a -> Exp
toExp Exp l
e)
hsStmtToGuard (Exts.LetStmt _ bs :: 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 h :: Stmt l
h                      = String -> Stmt l -> Guard
forall (f :: * -> *) e a.
(Functor f, Show (f ())) =>
String -> f e -> a
todo "hsStmtToGuard" Stmt l
h
-- TODO
-- (Exts.RecStmt _ _)


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

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

-- * ToDecs HsDecl HsBinds

instance ToDecs (Exts.Decl l) where
  toDecs :: Decl l -> [Dec]
toDecs _a :: Decl l
_a@(Exts.TypeSig _ ns :: [Name l]
ns t :: 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
l assoc :: Assoc l
assoc Nothing ops :: [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 9) [Op l]
ops)
  toDecs (Exts.InfixDecl _ assoc :: Assoc l
assoc (Just fixity :: Int
fixity) ops :: [Op l]
ops) =
    (Op l -> Dec) -> [Op l] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map (\op :: 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 _  -> FixityDirection
TH.InfixN
      Exts.AssocLeft _  -> FixityDirection
TH.InfixL
      Exts.AssocRight _ -> FixityDirection
TH.InfixR

  toDecs a :: 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 = (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