{-# 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 root :: 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)
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 root :: 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 (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 "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 (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 "newASTTypes") ((Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
transName [Name]
descs)

    [Dec] -> CompTrans [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> CompTrans [Dec]) -> [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
nameList1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
nameList2
  where

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

getLabels :: [Name] -> CompTrans [Type]
getLabels :: [Name] -> CompTrans [Type]
getLabels nms :: [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)
mapM Name -> CompTrans Type
toLabel [Name]
nms
  where
    toLabel :: Name -> CompTrans Type
toLabel n :: Name
n = do
      TyConI (DataD _ n' :: Name
n' _ _ _ _) <- 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 (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 (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)
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 nm :: String
nm types :: [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 (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)
sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Name -> [TyVarBndr] -> TypeQ -> Q Dec
tySynD (String -> Name
mkName String
nm) [] (TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeQ
sumType [Name]
types]
  where
    sumType :: [Name] -> TypeQ
sumType [] = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Attempting to make empty sum type"
    sumType ts :: [Name]
ts = (Name -> TypeQ -> TypeQ) -> TypeQ -> [Name] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a :: Name
a acc :: TypeQ
acc -> TypeQ
promotedConsT TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT Name
a TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
acc) TypeQ
promotedNilT [Name]
ts