{-# LANGUAGE TypeOperators      #-}
{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE TupleSections      #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE CPP                #-}
-- |This module provides some Template Haskell functionality to
-- help out the declaration of 'Deep' instances.
--
-- Note that we chose to not automate the whole process on purpose.
-- Sometimes the user will need to define standalone 'Generic'
-- instances for some select types in the family, some other times
-- the user might want better control over naming, for example.
-- Consequently, the most adaptable option is to provide
-- two TH utilities:
--
-- 1. Unfolding a family into a list of types until a fixpoint is reached,
-- given in 'unfoldFamilyInto'
-- 2. Declaring 'Deep' for a list of types, given in 'declareDeepFor'
--
-- The stepts in between unfolding the family and declaring 'Deep' vary
-- too much from case to case and hence, must be manually executed.
-- Let us run through  a simple example, which involves mutual
-- recursion and type synonyms in the AST of a pseudo-language.
--
-- > data Stmt var
-- >   = SAssign var (Exp var)
-- >   | SIf     (Exp var) (Stmt var) (Stmt var)
-- >   | SSeq    (Stmt var) (Stmt var)
-- >   | SReturn (Exp var)
-- >   | SDecl (Decl var)
-- >   | SSkip
-- >   deriving (Show, Generic)
-- >
-- > data ODecl var
-- >   = DVar var
-- >   | DFun var var (Stmt var)
-- >   deriving (Show, Generic)
-- >
-- > type Decl x = TDecl x
-- > type TDecl x = ODecl x
-- >
-- > data Exp var
-- >   = EVar  var
-- >   | ECall var (Exp var)
-- >   | EAdd (Exp var) (Exp var)
-- >   | ESub (Exp var) (Exp var)
-- >   | ELit Int
-- >   deriving (Show, Generic)
--
-- Now say we want to use some code written with /generics-simplistic/
-- over these datatypes above. We must declare the 'Deep'
-- instances for the types in the family and "GHC.Generics"
-- takes care of the rest.
--
-- The first step is in defining @Prim@ and @Fam@, which
-- will be type-level lists with the primitive types and the non-primitive,
-- or compound, types.
--
-- An easy way to gather /all/ types involved in the family is with
-- 'unfoldFamilyInto', like:
--
-- > unfoldFamilyInto "stmtFam" [t| Stmt Int |]
--
-- The call above will be expanded into:
--
-- > stmtFam :: [String]
-- > stmtFam = ["Generics.Simplistic.Example.Exp Int"
-- >           ,"Generics.Simplistic.Example.ODecl Int"
-- >           ,"Generics.Simplistic.Example.Stmt Int"
-- >           ,"Int"
-- >           ]
--
-- Which can then be inspected with GHCi and, with
-- some elbow-grease (or test-editting macros!) we can
-- easily generate the necessary type-level lists:
--
-- > type Fam = '[Generics.Simplistic.Example.Exp Int
-- >             ,Generics.Simplistic.Example.ODecl Int
-- >             ,Generics.Simplistic.Example.Stmt Int
-- >             ]
-- >
-- > type Prim = '[Int]
--
-- Finally, we are ready to call 'deriveDeepFor' and get
-- the instances declared.
--
-- > deriveDeepFor ''Prim ''Fam
--
-- The TH code above expands to:
--
-- > instance Deep Prim Fam (Exp Int)
-- > instance Deep Prim Fam (ODecl Int)
-- > instance Deep Prim Fam (Stmt Int)
--
-- This workflow is crucial to be able to work
-- with large mutually recursive families, and it becomes
-- especially easy if coupled with
-- a text editor with good macro support (read emacs and vim).
--
module Generics.Simplistic.Deep.TH
  ( unfoldFamilyInto
  , deriveDeepFor
  , deriveInstancesWith
  ) where

import Control.Monad.State
import Control.Arrow ((***))

import Language.Haskell.TH hiding (match)
import Language.Haskell.TH.Syntax hiding (lift)

import qualified Data.Set as S

import Generics.Simplistic.Deep

-- |Lists all the necessary types that should
-- have 'Generic' and 'Deep' instances. For example,
--
-- > data Rose2 a b = Fork (Either a b) [Rose2 a b]
-- > unfoldFamilyInto 'rose2tys [t| Rose2 Int Char |]
--
-- Will yield the following code:
--
-- > rose2tys :: String
-- > rose2tys = [ "Rose2 Int Char"
-- >            , "Either Int Char"
-- >            , "[Rose2 Int Char]"
-- >            , "Int"
-- >            , "Char"
-- >            ]
--
-- You should then use some elbow grease or your favorite text editor
-- and its provided macro functionality to produce:
--
-- > type Rose2Prim = '[Int , Char]
-- > type Rose2Fam  = '[Rose2 Int Char , Either Int Char , [Rose2 Int Char]]
-- > deriving instance Generic (Rose2 Int Char)
-- > deriving instance Generic (Either Int Char)
-- > instance Deep Rose2Prim Rose2Fam (Rose2 Int Char)
-- > instance Deep Rose2Prim Rose2Fam (Either Int Char)
-- > instance Deep Rose2Prim Rose2Fam [Rose2 Int Char]
--
-- Note that types like @Int@ will appear fully qualified,
-- this will need some renaming.
unfoldFamilyInto :: String -> Q Type -> Q [Dec]
unfoldFamilyInto :: String -> Q Type -> Q [Dec]
unfoldFamilyInto n :: String
n first :: Q Type
first = do
  STy
ty <- Q Type
first Q Type -> (Type -> Q STy) -> Q STy
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Q STy
forall (m :: * -> *). MonadFail m => Type -> m STy
convertType
  [STy]
allTys <- Set STy -> [STy]
forall a. Set a -> [a]
S.toList (Set STy -> [STy]) -> Q (Set STy) -> Q [STy]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Set STy) Q () -> Set STy -> Q (Set STy)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (STy -> StateT (Set STy) Q ()
process STy
ty) Set STy
forall a. Set a
S.empty
  Type
listStr <- [t| [String] |]
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Type -> Dec
SigD (String -> Name
mkName String
n) Type
listStr
         , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
n) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [STy] -> Exp
mkExp [STy]
allTys) []]
         ]
 where
   mkExp :: [STy] -> Exp
   mkExp :: [STy] -> Exp
mkExp = [Exp] -> Exp
ListE ([Exp] -> Exp) -> ([STy] -> [Exp]) -> [STy] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (STy -> Exp) -> [STy] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Lit -> Exp
LitE (Lit -> Exp) -> (STy -> Lit) -> STy -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (STy -> String) -> STy -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (STy -> Doc) -> STy -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Doc
forall a. Ppr a => a -> Doc
ppr (Type -> Doc) -> (STy -> Type) -> STy -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STy -> Type
trevnocType)

-- |Given two type-level lists @Prims@ and @Fam@, will generate
-- @instance Deep Prim Fam f@ for every @f@ in @Fam@.
deriveDeepFor :: Name -> Name -> Q [Dec]
deriveDeepFor :: Name -> Name -> Q [Dec]
deriveDeepFor pr :: Name
pr fam :: Name
fam =
  let qprim :: Q Type
qprim = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
pr
      qfam :: Q Type
qfam  = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
fam
   in (Type -> Q Type) -> Name -> Q [Dec]
deriveInstancesWith (\t :: Type
t -> [t| Deep $(qprim) $(qfam) $(return t) |]) Name
fam

-- |Given a function @f@ and a type level stored in @fam@,
-- 'deriveInstacesWith' will generate:
--
-- > instance f x
--
-- for each @x@ in @fam@. This function is mostly internal,
-- please check 'deriveDeepFor' and 'deriveGenericFor'.
deriveInstancesWith :: (Type -> Q Type) -- ^ Instance to derive
                    -> Name -- ^ fam
                    -> Q [Dec]
deriveInstancesWith :: (Type -> Q Type) -> Name -> Q [Dec]
deriveInstancesWith f :: Type -> Q Type
f fam :: Name
fam = do
  [Type]
tys <- Name -> Q [Type]
getTypeLevelList Name
fam
  [Type] -> (Type -> Q Dec) -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Type]
tys ((Type -> Q Dec) -> Q [Dec]) -> (Type -> Q Dec) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \ty :: Type
ty -> do
    Type
instTy <- Type -> Q Type
f Type
ty
    Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
instTy []


getTypeLevelList :: Name -> Q [Type]
getTypeLevelList :: Name -> Q [Type]
getTypeLevelList x :: Name
x = do
  Maybe Dec
mtyDecl <- Name -> Q (Maybe Dec)
reifyDec Name
x
  case Maybe Dec
mtyDecl of
    Nothing              -> String -> Q [Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Not a type declaration: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
x))
    Just (TySynD _ _ ty :: Type
ty) -> Type -> Q [Type]
getTyLL Type
ty
    Just d :: Dec
d -> String -> Q [Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Not a type-level list: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Dec -> Doc
forall a. Ppr a => a -> Doc
ppr Dec
d))
 where
   getTyLL :: Type -> Q [Type]
   getTyLL :: Type -> Q [Type]
getTyLL (SigT t :: Type
t _) = Type -> Q [Type]
getTyLL Type
t
   getTyLL PromotedNilT = [Type] -> Q [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return []
   getTyLL (AppT (AppT PromotedConsT a :: Type
a) as :: Type
as) = (Type
aType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:) ([Type] -> [Type]) -> Q [Type] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q [Type]
getTyLL Type
as
   getTyLL t :: Type
t = String -> Q [Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Not a type-level list: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t)

process :: STy -> StateT (S.Set STy) Q ()
process :: STy -> StateT (Set STy) Q ()
process ty :: STy
ty = do
  Set STy
tys <- StateT (Set STy) Q (Set STy)
forall s (m :: * -> *). MonadState s m => m s
get
  if STy
ty STy -> Set STy -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set STy
tys
  then () -> StateT (Set STy) Q ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  else do
    let (tyHd :: STy
tyHd , args :: [STy]
args) = STy -> (STy, [STy])
styFlatten STy
ty
    case STy
tyHd of
      ConST tyName :: Name
tyName -> do
        Maybe Dec
tyDecl <- Q (Maybe Dec) -> StateT (Set STy) Q (Maybe Dec)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Name -> Q (Maybe Dec)
reifyDec Name
tyName)
        case Maybe Dec
tyDecl of
          Just dec :: Dec
dec -> Dec -> [STy] -> StateT (Set STy) Q ()
processDecl Dec
dec [STy]
args
          Nothing  -> () -> StateT (Set STy) Q ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      _ -> String -> StateT (Set STy) Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Invalid type"

processDecl :: Dec -> [STy] -> StateT (S.Set STy) Q ()
processDecl :: Dec -> [STy] -> StateT (Set STy) Q ()
processDecl (DataD _ tyName :: Name
tyName vars :: [TyVarBndr]
vars _ cons :: [Con]
cons _) args :: [STy]
args = do
  (Set STy -> Set STy) -> StateT (Set STy) Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (STy -> Set STy -> Set STy
forall a. Ord a => a -> Set a -> Set a
S.insert (Name -> [STy] -> STy
styApp Name
tyName [STy]
args))
  let argVal :: [(Name, STy)]
argVal = [Name] -> [STy] -> [(Name, STy)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyvarName [TyVarBndr]
vars) [STy]
args
  (Con -> StateT (Set STy) Q ()) -> [Con] -> StateT (Set STy) Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([(Name, STy)] -> Con -> StateT (Set STy) Q ()
processCon [(Name, STy)]
argVal) [Con]
cons
processDecl (NewtypeD _ tyName :: Name
tyName vars :: [TyVarBndr]
vars _ con :: Con
con _) args :: [STy]
args = do
  (Set STy -> Set STy) -> StateT (Set STy) Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (STy -> Set STy -> Set STy
forall a. Ord a => a -> Set a -> Set a
S.insert (Name -> [STy] -> STy
styApp Name
tyName [STy]
args))
  let argVal :: [(Name, STy)]
argVal = [Name] -> [STy] -> [(Name, STy)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyvarName [TyVarBndr]
vars) [STy]
args
  [(Name, STy)] -> Con -> StateT (Set STy) Q ()
processCon [(Name, STy)]
argVal Con
con
processDecl (TySynD _ vars :: [TyVarBndr]
vars ty :: Type
ty) args :: [STy]
args = do
  STy
sty <- Type -> StateT (Set STy) Q STy
forall (m :: * -> *). MonadFail m => Type -> m STy
convertType Type
ty
  let argVal :: [(Name, STy)]
argVal = [Name] -> [STy] -> [(Name, STy)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyvarName [TyVarBndr]
vars) [STy]
args
  STy -> StateT (Set STy) Q ()
process ([(Name, STy)] -> STy -> STy
styReduce [(Name, STy)]
argVal STy
sty)
processDecl _ _
  = String -> StateT (Set STy) Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "unknown decl"

processCon :: [(Name , STy)] -> Con -> StateT (S.Set STy) Q ()
processCon :: [(Name, STy)] -> Con -> StateT (Set STy) Q ()
processCon argVal :: [(Name, STy)]
argVal con :: Con
con = do
  [STy]
fields <- (Type -> StateT (Set STy) Q STy)
-> [Type] -> StateT (Set STy) Q [STy]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((STy -> STy) -> StateT (Set STy) Q STy -> StateT (Set STy) Q STy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Name, STy)] -> STy -> STy
styReduce [(Name, STy)]
argVal) (StateT (Set STy) Q STy -> StateT (Set STy) Q STy)
-> (Type -> StateT (Set STy) Q STy)
-> Type
-> StateT (Set STy) Q STy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> StateT (Set STy) Q STy
forall (m :: * -> *). MonadFail m => Type -> m STy
convertType) (Con -> [Type]
conType Con
con)
  (STy -> StateT (Set STy) Q ()) -> [STy] -> StateT (Set STy) Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ STy -> StateT (Set STy) Q ()
process [STy]
fields

tyvarName :: TyVarBndr -> Name
tyvarName :: TyVarBndr -> Name
tyvarName (PlainTV n :: Name
n) = Name
n
tyvarName (KindedTV n :: Name
n _) = Name
n

vbtyTy :: VarBangType -> Type
vbtyTy :: VarBangType -> Type
vbtyTy (_ , _ , t :: Type
t) = Type
t

btyTy :: BangType -> Type
btyTy :: BangType -> Type
btyTy (_ , t :: Type
t) = Type
t

conType :: Con -> [Type]
conType :: Con -> [Type]
conType (NormalC _ btys :: [BangType]
btys)     = (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
btyTy [BangType]
btys
conType (RecC _ vbtys :: [VarBangType]
vbtys)       = (VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Type
vbtyTy [VarBangType]
vbtys
conType (InfixC tyl :: BangType
tyl _ tyr :: BangType
tyr)   = (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
btyTy [BangType
tyl , BangType
tyr]
conType (ForallC _ _ c :: Con
c)      = Con -> [Type]
conType Con
c
conType (GadtC _ btys :: [BangType]
btys _)     = (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
btyTy [BangType]
btys
conType (RecGadtC _ vbtys :: [VarBangType]
vbtys _) = (VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Type
vbtyTy [VarBangType]
vbtys

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

data STy
  = AppST STy STy
  | VarST Name
  | ConST Name
  deriving (STy -> STy -> Bool
(STy -> STy -> Bool) -> (STy -> STy -> Bool) -> Eq STy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: STy -> STy -> Bool
$c/= :: STy -> STy -> Bool
== :: STy -> STy -> Bool
$c== :: STy -> STy -> Bool
Eq , Int -> STy -> String -> String
[STy] -> String -> String
STy -> String
(Int -> STy -> String -> String)
-> (STy -> String) -> ([STy] -> String -> String) -> Show STy
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [STy] -> String -> String
$cshowList :: [STy] -> String -> String
show :: STy -> String
$cshow :: STy -> String
showsPrec :: Int -> STy -> String -> String
$cshowsPrec :: Int -> STy -> String -> String
Show, Eq STy
Eq STy =>
(STy -> STy -> Ordering)
-> (STy -> STy -> Bool)
-> (STy -> STy -> Bool)
-> (STy -> STy -> Bool)
-> (STy -> STy -> Bool)
-> (STy -> STy -> STy)
-> (STy -> STy -> STy)
-> Ord STy
STy -> STy -> Bool
STy -> STy -> Ordering
STy -> STy -> STy
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: STy -> STy -> STy
$cmin :: STy -> STy -> STy
max :: STy -> STy -> STy
$cmax :: STy -> STy -> STy
>= :: STy -> STy -> Bool
$c>= :: STy -> STy -> Bool
> :: STy -> STy -> Bool
$c> :: STy -> STy -> Bool
<= :: STy -> STy -> Bool
$c<= :: STy -> STy -> Bool
< :: STy -> STy -> Bool
$c< :: STy -> STy -> Bool
compare :: STy -> STy -> Ordering
$ccompare :: STy -> STy -> Ordering
$cp1Ord :: Eq STy
Ord)

#if __GLASGOW_HASKELL__ >= 808
convertType :: (MonadFail m) => Type -> m STy
#else
convertType :: (Monad m) => Type -> m STy
#endif
convertType :: Type -> m STy
convertType (AppT a :: Type
a b :: Type
b)  = STy -> STy -> STy
AppST (STy -> STy -> STy) -> m STy -> m (STy -> STy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m STy
forall (m :: * -> *). MonadFail m => Type -> m STy
convertType Type
a m (STy -> STy) -> m STy -> m STy
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m STy
forall (m :: * -> *). MonadFail m => Type -> m STy
convertType Type
b
convertType (SigT t :: Type
t _)  = Type -> m STy
forall (m :: * -> *). MonadFail m => Type -> m STy
convertType Type
t
convertType (VarT n :: Name
n)    = STy -> m STy
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> STy
VarST Name
n)
convertType (ConT n :: Name
n)    = STy -> m STy
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> STy
ConST Name
n)
convertType (ParensT t :: Type
t) = Type -> m STy
forall (m :: * -> *). MonadFail m => Type -> m STy
convertType Type
t
convertType ListT       = STy -> m STy
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> STy
ConST (String -> Name
mkName "[]"))
convertType (TupleT n :: Int
n)  = STy -> m STy
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> STy
ConST (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ '('Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) ',' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"))
convertType t :: Type
t           = String -> m STy
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("convertType: Unsupported Type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t)

trevnocType :: STy -> Type
trevnocType :: STy -> Type
trevnocType (AppST a :: STy
a b :: STy
b) = Type -> Type -> Type
AppT (STy -> Type
trevnocType STy
a) (STy -> Type
trevnocType STy
b)
trevnocType (VarST n :: Name
n)   = Name -> Type
VarT Name
n
trevnocType (ConST n :: Name
n)
  | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
mkName "[]" = Type
ListT
  | Name -> Bool
forall a. Show a => a -> Bool
isTupleN Name
n       = Int -> Type
TupleT (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Name -> String
forall a. Show a => a -> String
show Name
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
  | Bool
otherwise        = Name -> Type
ConT Name
n
  where isTupleN :: a -> Bool
isTupleN n0 :: a
n0 = Int -> String -> String
forall a. Int -> [a] -> [a]
take 2 (a -> String
forall a. Show a => a -> String
show a
n0) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "(,"

-- |Handy substitution function.
--
--  @stySubst t m n@ substitutes m for n within t, that is: t[m/n]
stySubst :: STy -> Name -> STy -> STy
stySubst :: STy -> Name -> STy -> STy
stySubst (AppST a :: STy
a b :: STy
b) m :: Name
m n :: STy
n = STy -> STy -> STy
AppST (STy -> Name -> STy -> STy
stySubst STy
a Name
m STy
n) (STy -> Name -> STy -> STy
stySubst STy
b Name
m STy
n)
stySubst (ConST a :: Name
a)   _ _ = Name -> STy
ConST Name
a
stySubst (VarST x :: Name
x)   m :: Name
m n :: STy
n
  | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m    = STy
n
  | Bool
otherwise = Name -> STy
VarST Name
x

-- |Just like subst, but applies a list of substitutions
styReduce :: [(Name , STy)] -> STy -> STy
styReduce :: [(Name, STy)] -> STy -> STy
styReduce parms :: [(Name, STy)]
parms t :: STy
t = ((Name, STy) -> STy -> STy) -> STy -> [(Name, STy)] -> STy
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(n :: Name
n , m :: STy
m) ty :: STy
ty -> STy -> Name -> STy -> STy
stySubst STy
ty Name
n STy
m) STy
t [(Name, STy)]
parms

-- |Flattens an application into a list of arguments;
--
--  @styFlatten (AppST (AppST Tree A) B) == (Tree , [A , B])@
styFlatten :: STy -> (STy , [STy])
styFlatten :: STy -> (STy, [STy])
styFlatten (AppST a :: STy
a b :: STy
b) = STy -> STy
forall a. a -> a
id (STy -> STy) -> ([STy] -> [STy]) -> (STy, [STy]) -> (STy, [STy])
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ([STy] -> [STy] -> [STy]
forall a. [a] -> [a] -> [a]
++ [STy
b]) ((STy, [STy]) -> (STy, [STy])) -> (STy, [STy]) -> (STy, [STy])
forall a b. (a -> b) -> a -> b
$ STy -> (STy, [STy])
styFlatten STy
a
styFlatten sty :: STy
sty         = (STy
sty , [])

styApp :: Name -> [STy] -> STy
styApp :: Name -> [STy] -> STy
styApp name :: Name
name args :: [STy]
args = STy -> [STy] -> STy
go (Name -> STy
ConST Name
name) ([STy] -> [STy]
forall a. [a] -> [a]
reverse [STy]
args)
  where go :: STy -> [STy] -> STy
go t :: STy
t [] = STy
t
        go t :: STy
t (x :: STy
x:xs :: [STy]
xs) = STy -> STy -> STy
AppST (STy -> [STy] -> STy
go STy
t [STy]
xs) STy
x

-- * Parsing Haskell's AST

reifyDec :: Name -> Q (Maybe Dec)
reifyDec :: Name -> Q (Maybe Dec)
reifyDec name :: Name
name =
  do Info
info <- Name -> Q Info
reify Name
name
     case Info
info of TyConI dec :: Dec
dec -> Maybe Dec -> Q (Maybe Dec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Maybe Dec
forall a. a -> Maybe a
Just Dec
dec)
                  _          -> Maybe Dec -> Q (Maybe Dec)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Dec
forall a. Maybe a
Nothing