content: {-# 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 root = do descs <- collectTypes root
                            withAllTypes descs $ liftM concat $ mapM deriveMulti 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 root = do
      descs <- collectTypes root
      nameList1 <- CompTrans $ lift $ mkList ''Name (mkName "origASTTypes") descs
      nameList2 <- CompTrans $ lift $ mkList ''Name (mkName "newASTTypes") (map transName descs)
  
      return $ nameList1 ++ nameList2
    where
  
      mkList :: Data t => Name -> Name -> [t] -> Q [Dec]
      mkList tNm name contents = sequence [ sigD name (appT listT (conT tNm))
                                          , valD (varP name) (normalB namesExp) []
                                          ]
        where
          namesExp = dataToExpQ (const Nothing) contents
  
  getLabels :: [Name] -> CompTrans [Type]
  getLabels nms = mapM toLabel nms
    where
      toLabel n = do
        TyConI (DataD _ n' _ _ _ _) <- CompTrans $ lift $ reify $ nameLab n
        return $ ConT n'
  
  -- | Retrieves the names of type parameters attached to a list of type declarations, referenced by name
  getTypeParamVars :: [Name] -> CompTrans [Name]
  getTypeParamVars = liftM concat . mapM 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 nm types = CompTrans $ lift $ sequence $ [tySynD (mkName nm) [] $ sumType types]
    where
      sumType [] = fail "Attempting to make empty sum type"
      sumType ts = foldr (\a acc -> promotedConsT `appT` conT a `appT` acc) promotedNilT ts
  