{-# LANGUAGE TemplateHaskell #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Trans
-- Copyright   :  (c) 2013 James Koppel
-- License     :  BSD3
--
-- Template Haskell to convert an ordinary mutually-recursive algebraic datatypes into a
-- set of independent, unfixed, sorted signatures suitable for use with the @compdata@ or @cubix-compdata@ packages.
--
--This package implements the algorithm described in Appendix A of
-- \"One Tool, Many Languages: Incremental Parametric Syntax for Multi-Language Transformation\", OOPSLA 2018
--
-- GHC has a phase restriction which prevents code generated by Template Haskell
-- being referred to by Template Haskell in the same file. Thus, when using this
-- library, you will need to spread invocations out over several files.
--
-- We will refer to the following example in the documentation:
--
-- @
-- module Foo where
-- data Arith = Add Atom Atom
-- data Atom = Var String | Const Lit
-- data Lit = Lit Int
-- @
--
--------------------------------------------------------------------------------

module Data.Comp.Trans (
    -- * Run @compdata@, with potential configuration
    CompTrans
  , runCompTrans

    -- ** Substitutions
  , withSubstitutions
  , getTypeParamVars

    -- ** Excluded types
  , withExcludedNames
  , standardExcludedNames

    -- ** Annotation propagation
  , withAnnotationProp
  , defaultPropAnn
  , defaultUnpropAnn

    -- * Derive multi-sorted compositional data types
  , deriveMultiComp
  , generateNameLists
  , makeSumType

    -- * Derive translation functions
  , T.deriveTrans
  , U.deriveUntrans

  -- * Uncategorized
  , getLabels
  ) where

import Control.Monad ( liftM )
import Control.Monad.Trans ( lift )

import Data.Data ( Data )

import Language.Haskell.TH.Quote ( dataToExpQ )
import Language.Haskell.TH

import qualified Data.Comp.Trans.DeriveTrans as T
import qualified Data.Comp.Trans.DeriveUntrans as U
import Data.Comp.Trans.DeriveMulti
import Data.Comp.Trans.Collect
import Data.Comp.Trans.Util as Util


-- |
-- Declares a multi-sorted compositional datatype isomorphic to the
-- given ADT.
-- 
-- /e.g./
-- 
-- @
-- import qualified Foo as F
-- runCompTrans $ deriveMultiComp ''F.Arith
-- @
-- 
-- will create
-- 
-- @
-- data ArithL
-- data AtomL
-- data LitL
-- 
-- data Arith e l where
--   Add :: e AtomL -> e AtomL -> Arith e ArithL
-- 
-- data Atom e l where
--   Var :: String -> Atom e AtomL
--   Const :: e LitL -> Atom e AtomL
-- 
-- data Lit (e :: * -> *) l where
--   Lit :: Int -> Lit e LitL
-- @
deriveMultiComp :: Name -> CompTrans [Dec]
deriveMultiComp :: Name -> CompTrans [Dec]
deriveMultiComp Name
root = do [Name]
descs <- Name -> CompTrans [Name]
collectTypes Name
root
                          [Name] -> CompTrans [Dec] -> CompTrans [Dec]
forall a. [Name] -> CompTrans a -> CompTrans a
withAllTypes [Name]
descs (CompTrans [Dec] -> CompTrans [Dec])
-> CompTrans [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ ([[Dec]] -> [Dec]) -> CompTrans [[Dec]] -> CompTrans [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (CompTrans [[Dec]] -> CompTrans [Dec])
-> CompTrans [[Dec]] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ (Name -> CompTrans [Dec]) -> [Name] -> CompTrans [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> CompTrans [Dec]
deriveMulti [Name]
descs

-- |
-- 
-- /e.g./
-- 
-- @
-- runCompTrans $ generateNameLists ''Arith
-- @
-- 
-- will create
-- 
-- @
-- origASTTypes = [mkName "Foo.Arith", mkName "Foo.Atom", mkName "Foo.Lit"]
-- newASTTypes  = [mkName "Arith", mkName "Atom", mkName "Lit"]
-- newASTLabels = map ConT [mkName "ArithL", mkName "AtomL', mkName "LitL"]
-- @
generateNameLists :: Name -> CompTrans [Dec]
generateNameLists :: Name -> CompTrans [Dec]
generateNameLists Name
root = do
    [Name]
descs <- Name -> CompTrans [Name]
collectTypes Name
root
    [Dec]
nameList1 <- ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q [Dec] -> CompTrans [Dec])
-> ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ Q [Dec] -> ReaderT TransCtx Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> ReaderT TransCtx Q [Dec])
-> Q [Dec] -> ReaderT TransCtx Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> [Name] -> Q [Dec]
forall t. Data t => Name -> Name -> [t] -> Q [Dec]
mkList ''Name (String -> Name
mkName String
"origASTTypes") [Name]
descs
    [Dec]
nameList2 <- ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q [Dec] -> CompTrans [Dec])
-> ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ Q [Dec] -> ReaderT TransCtx Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> ReaderT TransCtx Q [Dec])
-> Q [Dec] -> ReaderT TransCtx Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> [Name] -> Q [Dec]
forall t. Data t => Name -> Name -> [t] -> Q [Dec]
mkList ''Name (String -> Name
mkName String
"newASTTypes") ((Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
transName [Name]
descs)

    return $ [Dec]
nameList1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
nameList2
  where

    mkList :: Data t => Name -> Name -> [t] -> Q [Dec]
    mkList :: forall t. Data t => Name -> Name -> [t] -> Q [Dec]
mkList Name
tNm Name
name [t]
contents = [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
listT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tNm))
                                        , Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
name) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
namesExp) []
                                        ]
      where
        namesExp :: Q Exp
namesExp = (forall b. Data b => b -> Maybe (Q Exp)) -> [t] -> Q Exp
forall (m :: * -> *) a.
(Quote m, Data a) =>
(forall b. Data b => b -> Maybe (m Exp)) -> a -> m Exp
dataToExpQ (Maybe (Q Exp) -> b -> Maybe (Q Exp)
forall a b. a -> b -> a
const Maybe (Q Exp)
forall a. Maybe a
Nothing) [t]
contents

getLabels :: [Name] -> CompTrans [Type]
getLabels :: [Name] -> CompTrans [Type]
getLabels [Name]
nms = (Name -> CompTrans Type) -> [Name] -> CompTrans [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> CompTrans Type
toLabel [Name]
nms
  where
    toLabel :: Name -> CompTrans Type
toLabel Name
n = do
      TyConI (DataD [Type]
_ Name
n' [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
_ [DerivClause]
_) <- ReaderT TransCtx Q Info -> CompTrans Info
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Info -> CompTrans Info)
-> ReaderT TransCtx Q Info -> CompTrans Info
forall a b. (a -> b) -> a -> b
$ Q Info -> ReaderT TransCtx Q Info
forall (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> ReaderT TransCtx Q Info)
-> Q Info -> ReaderT TransCtx Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify (Name -> Q Info) -> Name -> Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameLab Name
n
      Type -> CompTrans Type
forall a. a -> CompTrans a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> CompTrans Type) -> Type -> CompTrans Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
n'

-- | Retrieves the names of type parameters attached to a list of type declarations, referenced by name
getTypeParamVars :: [Name] -> CompTrans [Name]
getTypeParamVars :: [Name] -> CompTrans [Name]
getTypeParamVars = ([[Name]] -> [Name]) -> CompTrans [[Name]] -> CompTrans [Name]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (CompTrans [[Name]] -> CompTrans [Name])
-> ([Name] -> CompTrans [[Name]]) -> [Name] -> CompTrans [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> CompTrans [Name]) -> [Name] -> CompTrans [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> CompTrans [Name]
getTypeArgs

-- |
-- Creates a type-level list from a list of TH names.
--
-- Example:
-- 
-- @
-- -- In Names.hs
-- import qualified Foo as F
-- runCompTrans $ generateNameLists ''F.Arith -- Defines newASTTypes
--
-- -- In Types.hs
-- import qualified Foo as F
-- import Names
-- runCompTrans $ deriveMult ''F.arith
-- runCompTrans $ makeSumType \"ArithSig\" newASTTypes
-- @
-- 
-- will create
-- 
-- @
-- type ArithSig = '[Arith, Atom, Lit]
-- @
makeSumType :: String -> [Name] -> CompTrans [Dec]
makeSumType :: String -> [Name] -> CompTrans [Dec]
makeSumType String
nm [Name]
types = ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q [Dec] -> CompTrans [Dec])
-> ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ Q [Dec] -> ReaderT TransCtx Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> ReaderT TransCtx Q [Dec])
-> Q [Dec] -> ReaderT TransCtx Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Name -> [TyVarBndr BndrVis] -> Q Type -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndr BndrVis] -> m Type -> m Dec
tySynD (String -> Name
mkName String
nm) [] (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Name] -> Q Type
forall {m :: * -> *}. (MonadFail m, Quote m) => [Name] -> m Type
sumType [Name]
types]
  where
    sumType :: [Name] -> m Type
sumType [] = String -> m Type
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Attempting to make empty sum type"
    sumType [Name]
ts = (Name -> m Type -> m Type) -> m Type -> [Name] -> m Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Name
a m Type
acc -> m Type
forall (m :: * -> *). Quote m => m Type
promotedConsT m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
a m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m Type
acc) m Type
forall (m :: * -> *). Quote m => m Type
promotedNilT [Name]
ts