{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.Nanopass.Xlate
  ( mkXlate
  , declareXlate
  , XlateDef(..)
  , XlateProd
  , XlateAuto(..)
  , XlateHoleDef(..)
  , XlateSyncatDef(..)
  ) where

import Language.Nanopass.LangDef

import Control.Monad (forM)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Either (lefts)
import Data.Functor ((<&>))
import Data.Functor.Identity (Identity(..))
import Data.List (nub)
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Language.Haskell.TH (Exp(AppE,VarE))
import Language.Haskell.TH (Q,Dec)
import Language.Haskell.TH (Type(AppT))

import qualified Control.Monad.Trans as M
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH


mkXlate :: DefdLang -> DefdLang -> Q [Dec]
mkXlate :: DefdLang -> DefdLang -> Q [Dec]
mkXlate DefdLang
l1 DefdLang
l2 = DefdLang -> DefdLang -> Q XlateDef
xlateDef DefdLang
l1 DefdLang
l2 Q XlateDef -> (XlateDef -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DefdLang -> DefdLang -> XlateDef -> Q [Dec]
declareXlate DefdLang
l1 DefdLang
l2

declareXlate :: DefdLang -> DefdLang -> XlateDef -> Q [Dec]
declareXlate :: DefdLang -> DefdLang -> XlateDef -> Q [Dec]
declareXlate DefdLang
l1 DefdLang
l2 XlateDef
xlate = do
  Dec
xlateType <- XlateDef -> Q Dec
declareType XlateDef
xlate
  Dec
xlateTypeI <- XlateDef -> Q Dec
declareTypeI XlateDef
xlate
  [Dec]
xlateLifter <- XlateDef -> Q [Dec]
declareXlateLifter XlateDef
xlate
  [Dec]
descends <- DefdLang -> DefdLang -> XlateDef -> Q [Dec]
defineDescend DefdLang
l1 DefdLang
l2 XlateDef
xlate
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
xlateType Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
xlateTypeI Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
xlateLifter [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
descends

---------------------------------------------
------ Gather Translation Requirements ------
---------------------------------------------

data XlateDef = XlateDef
  { XlateDef -> [Name]
xlateParams :: [TH.Name] -- ^ the type parameters of both languages, merged
  , XlateDef -> Name
xlateFParam :: TH.Name -- ^ a type for an Applicative parameter
  , XlateDef -> [XlateSyncatDef]
xlateSyncats :: [XlateSyncatDef]
    -- ^ information about the syntactic cateories shared by both source and target
    -- this is used to allow users to override the bahavior of automatic translation
  , XlateDef -> [Either XlateHoleDef XlateAuto]
xlateProds :: [XlateProd] -- FIXME these should go under xlateSyncats, probly
    -- ^ information about the productions in the source that are missing in the target
    -- this is so that we require the user to supply these in an Xlate type
  , XlateDef -> DefdLang
xlateFrom :: DefdLang
  , XlateDef -> DefdLang
xlateTo :: DefdLang
  }
type XlateProd = Either XlateHoleDef XlateAuto
data XlateAuto = XlateAuto
  { XlateAuto -> String
syncatName :: String
  , XlateAuto -> String
prodName :: String
  , XlateAuto -> [Name -> Name -> Exp]
autoArgs :: [TH.Name -> TH.Name -> Exp] -- functions from xlate and subterm variables to auto-translator
  }
data XlateHoleDef = XlateHoleDef
  { XlateHoleDef -> String
syncatName :: String -- the name of the syntactic category shared by source and target
  , XlateHoleDef -> String
prodName :: String -- the name of the source production
  , XlateHoleDef -> [Type]
holeArgs :: [TH.Type] -- the types of the subterms of the source production
  , XlateHoleDef -> Type
holeResult :: TH.Type -- the type of the target syntactic category that must be supplied
  }
data XlateSyncatDef = XlateSyncatDef
  { XlateSyncatDef -> String
syncatName :: String -- the name of the syntactic category shared by source and target
  , XlateSyncatDef -> Type
fromType :: TH.Type -- parameterized type of the source language at this syntactic category
  , XlateSyncatDef -> Type
toType :: TH.Type -- parameterized type of the target language at this syntactic category
  }

xlateDef :: DefdLang -> DefdLang -> Q XlateDef
xlateDef :: DefdLang -> DefdLang -> Q XlateDef
xlateDef DefdLang
l1 DefdLang
l2 = do
  let xlateParams :: [Name]
xlateParams = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub (DefdLang
l1.defdLangParams [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ DefdLang
l2.defdLangParams)
  Name
xlateFParam <- if String -> Name
TH.mkName String
"f" Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
xlateParams
    then String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"f"
    else Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Q Name) -> Name -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
"f"
  [Either XlateHoleDef XlateAuto]
xlateProds <- ([[Either XlateHoleDef XlateAuto]]
 -> [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
-> Q [Either XlateHoleDef XlateAuto]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Either XlateHoleDef XlateAuto]]
-> [Either XlateHoleDef XlateAuto]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Either XlateHoleDef XlateAuto]]
 -> Q [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
-> Q [Either XlateHoleDef XlateAuto]
forall a b. (a -> b) -> a -> b
$ [(String, DefdSyncatType)]
-> ((String, DefdSyncatType) -> Q [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map String DefdSyncatType -> [(String, DefdSyncatType)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map String DefdSyncatType -> [(String, DefdSyncatType)])
-> Map String DefdSyncatType -> [(String, DefdSyncatType)]
forall a b. (a -> b) -> a -> b
$ DefdLang
l1.defdSyncats) (((String, DefdSyncatType) -> Q [Either XlateHoleDef XlateAuto])
 -> Q [[Either XlateHoleDef XlateAuto]])
-> ((String, DefdSyncatType) -> Q [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
forall a b. (a -> b) -> a -> b
$ DefdLang
-> DefdLang
-> (String, DefdSyncatType)
-> Q [Either XlateHoleDef XlateAuto]
detectHoles DefdLang
l1 DefdLang
l2
  let xlateSyncats :: [XlateSyncatDef]
xlateSyncats = ((String, DefdSyncatType) -> [XlateSyncatDef])
-> [(String, DefdSyncatType)] -> [XlateSyncatDef]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DefdLang
-> DefdLang -> (String, DefdSyncatType) -> [XlateSyncatDef]
detectOverrides DefdLang
l1 DefdLang
l2) ([(String, DefdSyncatType)] -> [XlateSyncatDef])
-> [(String, DefdSyncatType)] -> [XlateSyncatDef]
forall a b. (a -> b) -> a -> b
$ Map String DefdSyncatType -> [(String, DefdSyncatType)]
forall k a. Map k a -> [(k, a)]
Map.toAscList DefdLang
l1.defdSyncats
  XlateDef -> Q XlateDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XlateDef -> Q XlateDef) -> XlateDef -> Q XlateDef
forall a b. (a -> b) -> a -> b
$ XlateDef
    { [Name]
xlateParams :: [Name]
$sel:xlateParams:XlateDef :: [Name]
xlateParams
    , Name
xlateFParam :: Name
$sel:xlateFParam:XlateDef :: Name
xlateFParam
    , [XlateSyncatDef]
xlateSyncats :: [XlateSyncatDef]
$sel:xlateSyncats:XlateDef :: [XlateSyncatDef]
xlateSyncats
    , [Either XlateHoleDef XlateAuto]
xlateProds :: [Either XlateHoleDef XlateAuto]
$sel:xlateProds:XlateDef :: [Either XlateHoleDef XlateAuto]
xlateProds
    , $sel:xlateFrom:XlateDef :: DefdLang
xlateFrom = DefdLang
l1
    , $sel:xlateTo:XlateDef :: DefdLang
xlateTo = DefdLang
l2
    }

detectHoles :: DefdLang -> DefdLang -> (String, DefdSyncatType) -> Q [Either XlateHoleDef XlateAuto]
detectHoles :: DefdLang
-> DefdLang
-> (String, DefdSyncatType)
-> Q [Either XlateHoleDef XlateAuto]
detectHoles DefdLang
l1 DefdLang
l2 (String
sName, DefdSyncatType
s1) = case String -> Map String DefdSyncatType -> Maybe DefdSyncatType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
sName DefdLang
l2.defdSyncats of
  Maybe DefdSyncatType
Nothing -> [Either XlateHoleDef XlateAuto]
-> Q [Either XlateHoleDef XlateAuto]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- no translation required: no l2 ctor can use the a type corresponding to this l1 type (because it doesn't exist)
  Just DefdSyncatType
s2 -> ([[Either XlateHoleDef XlateAuto]]
 -> [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
-> Q [Either XlateHoleDef XlateAuto]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Either XlateHoleDef XlateAuto]]
-> [Either XlateHoleDef XlateAuto]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Either XlateHoleDef XlateAuto]]
 -> Q [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
-> Q [Either XlateHoleDef XlateAuto]
forall a b. (a -> b) -> a -> b
$ [(String, DefdProd)]
-> ((String, DefdProd) -> Q [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map String DefdProd -> [(String, DefdProd)]
forall k a. Map k a -> [(k, a)]
Map.toAscList DefdSyncatType
s1.defdProds) (((String, DefdProd) -> Q [Either XlateHoleDef XlateAuto])
 -> Q [[Either XlateHoleDef XlateAuto]])
-> ((String, DefdProd) -> Q [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
forall a b. (a -> b) -> a -> b
$ DefdSyncatType
-> (String, DefdProd) -> Q [Either XlateHoleDef XlateAuto]
detectHoleCtors DefdSyncatType
s2
  where
  detectHoleCtors :: DefdSyncatType -> (String, DefdProd) -> Q [Either XlateHoleDef XlateAuto]
  detectHoleCtors :: DefdSyncatType
-> (String, DefdProd) -> Q [Either XlateHoleDef XlateAuto]
detectHoleCtors DefdSyncatType
s2 (String
pName, DefdProd
prod1) = case String -> Map String DefdProd -> Maybe DefdProd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
pName DefdSyncatType
s2.defdProds of
    -- a required hole, because there is no constructor to target
    Maybe DefdProd
Nothing -> [Either XlateHoleDef XlateAuto]
-> Q [Either XlateHoleDef XlateAuto]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [XlateHoleDef -> Either XlateHoleDef XlateAuto
forall a b. a -> Either a b
Left (XlateHoleDef -> Either XlateHoleDef XlateAuto)
-> XlateHoleDef -> Either XlateHoleDef XlateAuto
forall a b. (a -> b) -> a -> b
$ String -> DefdProd -> XlateHoleDef
createHole String
pName DefdProd
prod1]
    Just DefdProd
prod2
      -- no custom translation required: the arguments of one constructor match up with the arguments of the other
      | [TypeDesc]
tys1 <- (DefdSubterm -> TypeDesc
defdSubtermType (DefdSubterm -> TypeDesc) -> [DefdSubterm] -> [TypeDesc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefdProd
prod1.defdSubterms)
      , [TypeDesc]
tys2 <- (DefdSubterm -> TypeDesc
defdSubtermType (DefdSubterm -> TypeDesc) -> [DefdSubterm] -> [TypeDesc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefdProd
prod2.defdSubterms)
      , [TypeDesc]
tys1 [TypeDesc] -> [TypeDesc] -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeDesc]
tys2 -> MaybeT Q [Name -> Name -> Exp] -> Q (Maybe [Name -> Name -> Exp])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (TypeDesc -> MaybeT Q (Name -> Name -> Exp)
createAuto (TypeDesc -> MaybeT Q (Name -> Name -> Exp))
-> [TypeDesc] -> MaybeT Q [Name -> Name -> Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [TypeDesc]
tys1) Q (Maybe [Name -> Name -> Exp])
-> (Maybe [Name -> Name -> Exp]
    -> Q [Either XlateHoleDef XlateAuto])
-> Q [Either XlateHoleDef XlateAuto]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe [Name -> Name -> Exp]
Nothing -> [Either XlateHoleDef XlateAuto]
-> Q [Either XlateHoleDef XlateAuto]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [XlateHoleDef -> Either XlateHoleDef XlateAuto
forall a b. a -> Either a b
Left (XlateHoleDef -> Either XlateHoleDef XlateAuto)
-> XlateHoleDef -> Either XlateHoleDef XlateAuto
forall a b. (a -> b) -> a -> b
$ String -> DefdProd -> XlateHoleDef
createHole String
pName DefdProd
prod1] -- a required hole because no auto-translation possible
          Just [Name -> Name -> Exp]
autoArgs -> do
            [Either XlateHoleDef XlateAuto]
-> Q [Either XlateHoleDef XlateAuto]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [XlateAuto -> Either XlateHoleDef XlateAuto
forall a b. b -> Either a b
Right XlateAuto{$sel:syncatName:XlateAuto :: String
syncatName=String
sName,$sel:prodName:XlateAuto :: String
prodName=String
pName,[Name -> Name -> Exp]
autoArgs :: [Name -> Name -> Exp]
$sel:autoArgs:XlateAuto :: [Name -> Name -> Exp]
autoArgs}]
      -- a required hole, because the arguments of the constructors do not have the same structure
      | Bool
otherwise  -> [Either XlateHoleDef XlateAuto]
-> Q [Either XlateHoleDef XlateAuto]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [XlateHoleDef -> Either XlateHoleDef XlateAuto
forall a b. a -> Either a b
Left (XlateHoleDef -> Either XlateHoleDef XlateAuto)
-> XlateHoleDef -> Either XlateHoleDef XlateAuto
forall a b. (a -> b) -> a -> b
$ String -> DefdProd -> XlateHoleDef
createHole String
pName DefdProd
prod1]
  createHole :: String -> DefdProd -> XlateHoleDef
createHole String
pName DefdProd
prod1 =
    let holeArgs :: [Type]
holeArgs = ((DefdSubterm -> Type) -> [DefdSubterm] -> [Type])
-> [DefdSubterm] -> (DefdSubterm -> Type) -> [Type]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DefdSubterm -> Type) -> [DefdSubterm] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (DefdProd -> [DefdSubterm]
defdSubterms DefdProd
prod1) ((DefdSubterm -> Type) -> [Type])
-> (DefdSubterm -> Type) -> [Type]
forall a b. (a -> b) -> a -> b
$ \DefdSubterm
subterm ->
          DefdLang -> TypeDesc -> Type
interpretTypeDesc DefdLang
l1 DefdSubterm
subterm.defdSubtermType
        holeCtor :: Type
holeCtor = Name -> Type
TH.ConT (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DefdLang
l2.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sName)
        holeResult :: Type
holeResult = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
holeCtor (Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefdLang
l2.defdLangParams)
     in XlateHoleDef{$sel:syncatName:XlateHoleDef :: String
syncatName=String
sName,$sel:prodName:XlateHoleDef :: String
prodName=String
pName,[Type]
holeArgs :: [Type]
$sel:holeArgs:XlateHoleDef :: [Type]
holeArgs,Type
holeResult :: Type
$sel:holeResult:XlateHoleDef :: Type
holeResult}

detectOverrides :: DefdLang -> DefdLang -> (String, DefdSyncatType) -> [XlateSyncatDef]
detectOverrides :: DefdLang
-> DefdLang -> (String, DefdSyncatType) -> [XlateSyncatDef]
detectOverrides DefdLang
l1 DefdLang
l2 (String
sName, DefdSyncatType
_) = case String -> Map String DefdSyncatType -> Maybe DefdSyncatType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
sName DefdLang
l2.defdSyncats of
  Maybe DefdSyncatType
Nothing -> [] -- no translation required: no l2 ctor can use the a type corresponding to this l1 type (because it doesn't exist)
  Just DefdSyncatType
_ ->
    let fromTypeCtor :: Type
fromTypeCtor = Name -> Type
TH.ConT (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DefdLang
l1.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sName)
        fromType :: Type
fromType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
fromTypeCtor (Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefdLang
l1.defdLangParams)
        toTypeCtor :: Type
toTypeCtor = Name -> Type
TH.ConT (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DefdLang
l2.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sName)
        toType :: Type
toType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
toTypeCtor (Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefdLang
l2.defdLangParams)
     in [XlateSyncatDef{$sel:syncatName:XlateSyncatDef :: String
syncatName = String
sName,Type
fromType :: Type
$sel:fromType:XlateSyncatDef :: Type
fromType,Type
toType :: Type
$sel:toType:XlateSyncatDef :: Type
toType}]

createAuto :: TypeDesc -> MaybeT Q (TH.Name -> TH.Name -> Exp)
createAuto :: TypeDesc -> MaybeT Q (Name -> Name -> Exp)
createAuto (RecursiveType String
sName) = do
  let repName :: Name
repName = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"descend" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sName
      auto :: Name -> Name -> Exp
auto Name
xlateVar Name
argVar = Name -> Exp
VarE Name
repName Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
xlateVar Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
argVar
  (Name -> Name -> Exp) -> MaybeT Q (Name -> Name -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
auto
createAuto (VarType Name
_) = do
  let auto :: p -> Name -> Exp
auto p
_ Name
argVar = Name -> Exp
VarE 'pure Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
argVar
  (Name -> Name -> Exp) -> MaybeT Q (Name -> Name -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
forall {p}. p -> Name -> Exp
auto
createAuto (CtorType Name
tyName [TypeDesc]
ts)
  | (TypeDesc -> Bool) -> [TypeDesc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (TypeDesc -> Bool) -> TypeDesc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDesc -> Bool
containsGrammar) [TypeDesc]
ts = do
    let auto :: p -> Name -> Exp
auto p
_ Name
argVar = Name -> Exp
VarE 'pure Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
argVar
    (Name -> Name -> Exp) -> MaybeT Q (Name -> Name -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
forall {p}. p -> Name -> Exp
auto
  | TypeDesc
t:[TypeDesc]
ts' <- [TypeDesc] -> [TypeDesc]
forall a. [a] -> [a]
reverse [TypeDesc]
ts
  , (TypeDesc -> Bool) -> [TypeDesc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (TypeDesc -> Bool) -> TypeDesc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDesc -> Bool
containsGrammar) [TypeDesc]
ts' = do
      let travCandidate :: Type
travCandidate = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
TH.ConT Name
tyName) (DefdLang -> TypeDesc -> Type
interpretTypeDesc DefdLang
forall a. HasCallStack => a
undefined (TypeDesc -> Type) -> [TypeDesc] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDesc]
ts')
      Bool
isTraversable <- Q Bool -> MaybeT Q Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift (Q Bool -> MaybeT Q Bool) -> Q Bool -> MaybeT Q Bool
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Q Bool
TH.isInstance ''Traversable [Type
travCandidate]
      if Bool
isTraversable then TypeDesc -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc
t else MaybeT Q (Name -> Name -> Exp)
forall (m :: * -> *) a. Monad m => MaybeT m a
hoistNothing
  -- TODO maybe try Bitraversable
  | Bool
otherwise = MaybeT Q (Name -> Name -> Exp)
forall (m :: * -> *) a. Monad m => MaybeT m a
hoistNothing
createAuto (ListType TypeDesc
t) = TypeDesc -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc
t
createAuto (MaybeType TypeDesc
t) = TypeDesc -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc
t
createAuto (NonEmptyType TypeDesc
t) = TypeDesc -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc
t
createAuto (TupleType TypeDesc
t1 TypeDesc
t2 [TypeDesc]
ts) = do
  Exp
tupleMaker <- do
    [Name]
tVars <- [Int] -> (Int -> MaybeT Q Name) -> MaybeT Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1..[TypeDesc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TypeDesc
t1TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:TypeDesc
t2TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:[TypeDesc]
ts)] ((Int -> MaybeT Q Name) -> MaybeT Q [Name])
-> (Int -> MaybeT Q Name) -> MaybeT Q [Name]
forall a b. (a -> b) -> a -> b
$ \Int
i -> Q Name -> MaybeT Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift (Q Name -> MaybeT Q Name) -> Q Name -> MaybeT Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String
"t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
    Exp -> MaybeT Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> MaybeT Q Exp) -> Exp -> MaybeT Q Exp
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
TH.LamE (Name -> Pat
TH.VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tVars) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TH.TupE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE (Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
tVars)
  ([Name]
args', [Name -> Name -> Exp]
autos') <- ([(Name, Name -> Name -> Exp)] -> ([Name], [Name -> Name -> Exp]))
-> MaybeT Q [(Name, Name -> Name -> Exp)]
-> MaybeT Q ([Name], [Name -> Name -> Exp])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Name, Name -> Name -> Exp)] -> ([Name], [Name -> Name -> Exp])
forall a b. [(a, b)] -> ([a], [b])
unzip (MaybeT Q [(Name, Name -> Name -> Exp)]
 -> MaybeT Q ([Name], [Name -> Name -> Exp]))
-> MaybeT Q [(Name, Name -> Name -> Exp)]
-> MaybeT Q ([Name], [Name -> Name -> Exp])
forall a b. (a -> b) -> a -> b
$ [(Int, TypeDesc)]
-> ((Int, TypeDesc) -> MaybeT Q (Name, Name -> Name -> Exp))
-> MaybeT Q [(Name, Name -> Name -> Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int] -> [TypeDesc] -> [(Int, TypeDesc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1::Int)..] (TypeDesc
t1TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:TypeDesc
t2TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:[TypeDesc]
ts)) (((Int, TypeDesc) -> MaybeT Q (Name, Name -> Name -> Exp))
 -> MaybeT Q [(Name, Name -> Name -> Exp)])
-> ((Int, TypeDesc) -> MaybeT Q (Name, Name -> Name -> Exp))
-> MaybeT Q [(Name, Name -> Name -> Exp)]
forall a b. (a -> b) -> a -> b
$ \(Int
i, TypeDesc
t) -> do
    Name -> Name -> Exp
auto' <- TypeDesc -> MaybeT Q (Name -> Name -> Exp)
createAuto TypeDesc
t
    Name
arg' <- Q Name -> MaybeT Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift (Q Name -> MaybeT Q Name) -> Q Name -> MaybeT Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String
"a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
    (Name, Name -> Name -> Exp) -> MaybeT Q (Name, Name -> Name -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
arg', Name -> Name -> Exp
auto')
  let auto :: Name -> Name -> Exp
auto Name
xlateVar Name
argVar =
        let elemAuto :: (Name -> t -> t) -> t -> t
elemAuto Name -> t -> t
auto' t
arg' = Name -> t -> t
auto' Name
xlateVar t
arg'
            lam :: Exp
lam = [Pat] -> Exp -> Exp
TH.LamE [[Pat] -> Pat
TH.TupP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
TH.VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args'] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$
              (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
idiomAppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) Exp
tupleMaker) (((Name -> Name -> Exp) -> Name -> Exp)
-> [Name -> Name -> Exp] -> [Name] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name -> Name -> Exp) -> Name -> Exp
forall {t} {t}. (Name -> t -> t) -> t -> t
elemAuto [Name -> Name -> Exp]
autos' [Name]
args')
         in Exp
lam Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
argVar
  (Name -> Name -> Exp) -> MaybeT Q (Name -> Name -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
auto
createAuto (MapType TypeDesc
k TypeDesc
v)
  | Bool -> Bool
not (TypeDesc -> Bool
containsGrammar TypeDesc
k) = TypeDesc -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc
v
  | Bool
otherwise = MaybeT Q (Name -> Name -> Exp)
forall (m :: * -> *) a. Monad m => MaybeT m a
hoistNothing

traversableAuto :: TypeDesc -> MaybeT Q (TH.Name -> TH.Name -> Exp)
traversableAuto :: TypeDesc -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc
t = do
  Name
var <- Q Name -> MaybeT Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift (Q Name -> MaybeT Q Name) -> Q Name -> MaybeT Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"x"
  Name -> Name -> Exp
auto' <- TypeDesc -> MaybeT Q (Name -> Name -> Exp)
createAuto TypeDesc
t
  let auto :: Name -> Name -> Exp
auto Name
xlateVar Name
argVar =
        let lam :: Exp
lam = [Pat] -> Exp -> Exp
TH.LamE [Name -> Pat
TH.VarP Name
var] (Name -> Name -> Exp
auto' Name
xlateVar Name
var)
         in Name -> Exp
VarE 'traverse Exp -> Exp -> Exp
`AppE` Exp
lam Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
argVar
  (Name -> Name -> Exp) -> MaybeT Q (Name -> Name -> Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
auto


---------------------------------
------ Declare XLate Types ------
---------------------------------

declareType :: XlateDef -> Q Dec
declareType :: XlateDef -> Q Dec
declareType XlateDef
x = do
  Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
TH.putDoc (Name -> DocLoc
TH.DeclDoc Name
xlateName) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ String
"This type is used to parameterize the nanopass-generated translation functions @descend\\<Syntactic Category\\>@."
    , String
"It has members for:"
    , String
""
    , String
"  * each constructor that could not be translated"
    , String
"    (because it does not appear in the target language,"
    , String
"     because it has different subterms in the target language, or"
    , String
"     because nanopass does not understand the type of one or more of the subterms)"
    , String
"  * each syntactic category of the source language shared by the target,"
    , String
"    which allows a pass to override the default translation."
    , String
"    When no override is needed, these members can be initialized with 'const Nothing'."
    ]
  [(Name, Bang, Type)]
holes <- [XlateHoleDef]
-> (XlateHoleDef -> Q (Name, Bang, Type)) -> Q [(Name, Bang, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Either XlateHoleDef XlateAuto] -> [XlateHoleDef]
forall a b. [Either a b] -> [a]
lefts ([Either XlateHoleDef XlateAuto] -> [XlateHoleDef])
-> [Either XlateHoleDef XlateAuto] -> [XlateHoleDef]
forall a b. (a -> b) -> a -> b
$ XlateDef -> [Either XlateHoleDef XlateAuto]
xlateProds XlateDef
x) ((XlateHoleDef -> Q (Name, Bang, Type)) -> Q [(Name, Bang, Type)])
-> (XlateHoleDef -> Q (Name, Bang, Type)) -> Q [(Name, Bang, Type)]
forall a b. (a -> b) -> a -> b
$ \XlateHoleDef
hole -> do
    let name :: Name
name = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead XlateHoleDef
hole.syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateHoleDef
hole.prodName
        r :: Type
r = Name -> Type
TH.VarT XlateDef
x.xlateFParam Type -> Type -> Type
`AppT` XlateHoleDef
hole.holeResult
        t :: Type
t = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
ArrT Type
r XlateHoleDef
hole.holeArgs
    Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
TH.putDoc (Name -> DocLoc
TH.DeclDoc Name
name) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"No automatic translation for"
      , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"the v'", XlateDef
x.xlateFrom.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateHoleDef
hole.prodName, String
"' production "
        , String
"of t'", XlateDef
x.xlateFrom.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateHoleDef
hole.syncatName, String
"'"
        ]
      , String
"could be generated by Nanopass."
      ]
    (Name, Bang, Type) -> Q (Name, Bang, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Bang
noBang, Type
t)
  [(Name, Bang, Type)]
overrides <- [XlateSyncatDef]
-> (XlateSyncatDef -> Q (Name, Bang, Type))
-> Q [(Name, Bang, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM XlateDef
x.xlateSyncats ((XlateSyncatDef -> Q (Name, Bang, Type))
 -> Q [(Name, Bang, Type)])
-> (XlateSyncatDef -> Q (Name, Bang, Type))
-> Q [(Name, Bang, Type)]
forall a b. (a -> b) -> a -> b
$ \XlateSyncatDef
syncat -> do
    let name :: Name
name = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead XlateSyncatDef
syncat.syncatName
        r :: Type
r = Name -> Type
TH.ConT ''Maybe Type -> Type -> Type
`AppT` (Name -> Type
TH.VarT XlateDef
x.xlateFParam Type -> Type -> Type
`AppT` XlateSyncatDef
syncat.toType)
    Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
TH.putDoc (Name -> DocLoc
TH.DeclDoc Name
name) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"This member allows you to override the default translation for"
      , [String] -> String
unwords
        [ String
"The", String
"t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateDef
x.xlateFrom.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateSyncatDef
syncat.syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
        , String
"syntactic category."
        ]
      , String
"Produce a 'Just' value to override the automatic translation."
      , String
"If no overrides are needed, use @'const' 'Nothing'@."
      ]
    (Name, Bang, Type) -> Q (Name, Bang, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Bang
noBang, Type -> Type -> Type
ArrT XlateSyncatDef
syncat.fromType Type
r)
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD [] Name
xlateName [TyVarBndr ()]
tvs Maybe Type
forall a. Maybe a
Nothing
    [Name -> [(Name, Bang, Type)] -> Con
TH.RecC Name
xlateName ([(Name, Bang, Type)] -> Con) -> [(Name, Bang, Type)] -> Con
forall a b. (a -> b) -> a -> b
$ [(Name, Bang, Type)]
holes [(Name, Bang, Type)]
-> [(Name, Bang, Type)] -> [(Name, Bang, Type)]
forall a. [a] -> [a] -> [a]
++ [(Name, Bang, Type)]
overrides]
    []
  where
  xlateName :: Name
xlateName = String -> Name
TH.mkName String
"Xlate"
  tvs :: [TyVarBndr ()]
tvs = (Name -> () -> TyVarBndr ()) -> () -> Name -> TyVarBndr ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV () (Name -> TyVarBndr ()) -> [Name] -> [TyVarBndr ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XlateDef -> [Name]
xlateParams XlateDef
x [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [XlateDef -> Name
xlateFParam XlateDef
x]

declareTypeI :: XlateDef -> Q Dec
declareTypeI :: XlateDef -> Q Dec
declareTypeI XlateDef
x = do
  Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
TH.putDoc (Name -> DocLoc
TH.DeclDoc Name
xlateName) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ String
"This type is used to parameterize the nanopass-generated translation functions @descend*I@."
    , String
"It is the pure (i.e. does not require an 'Applicative') version of 'Xlate'."
    , String
""
    , String
"See 'Xlate' for more detail."
    ]
  [(Name, Bang, Type)]
holes <- [XlateHoleDef]
-> (XlateHoleDef -> Q (Name, Bang, Type)) -> Q [(Name, Bang, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Either XlateHoleDef XlateAuto] -> [XlateHoleDef]
forall a b. [Either a b] -> [a]
lefts XlateDef
x.xlateProds) ((XlateHoleDef -> Q (Name, Bang, Type)) -> Q [(Name, Bang, Type)])
-> (XlateHoleDef -> Q (Name, Bang, Type)) -> Q [(Name, Bang, Type)]
forall a b. (a -> b) -> a -> b
$ \XlateHoleDef
hole -> do
    let name :: Name
name = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead XlateHoleDef
hole.syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateHoleDef
hole.prodName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"I"
        t :: Type
t = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
ArrT XlateHoleDef
hole.holeResult XlateHoleDef
hole.holeArgs
    Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
TH.putDoc (Name -> DocLoc
TH.DeclDoc Name
name) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"No automatic translation for"
      , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"the v'", XlateDef
x.xlateFrom.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateHoleDef
hole.prodName, String
"' production "
        , String
"of t'", XlateDef
x.xlateFrom.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateHoleDef
hole.syncatName, String
"'"
        ]
      , String
"could be generated by Nanopass."
      ]
    (Name, Bang, Type) -> Q (Name, Bang, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Bang
noBang, Type
t)
  [(Name, Bang, Type)]
overrides <- [XlateSyncatDef]
-> (XlateSyncatDef -> Q (Name, Bang, Type))
-> Q [(Name, Bang, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM XlateDef
x.xlateSyncats ((XlateSyncatDef -> Q (Name, Bang, Type))
 -> Q [(Name, Bang, Type)])
-> (XlateSyncatDef -> Q (Name, Bang, Type))
-> Q [(Name, Bang, Type)]
forall a b. (a -> b) -> a -> b
$ \XlateSyncatDef
syncat -> do
    let name :: Name
name = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead XlateSyncatDef
syncat.syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"I"
        r :: Type
r = Name -> Type
TH.ConT ''Maybe Type -> Type -> Type
`AppT` XlateSyncatDef
syncat.toType
    Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
TH.putDoc (Name -> DocLoc
TH.DeclDoc Name
name) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"This member allows you to override the default translation for"
      , [String] -> String
unwords
        [ String
"The", String
"t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateDef
x.xlateFrom.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateSyncatDef
syncat.syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
        , String
"syntactic category."
        ]
      , String
"Produce a 'Just' value to override the automatic translation."
      , String
"If no overrides are needed, use @'const' 'Nothing'@."
      ]
    (Name, Bang, Type) -> Q (Name, Bang, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Bang
noBang, Type -> Type -> Type
ArrT XlateSyncatDef
syncat.fromType Type
r)
  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD [] Name
xlateName [TyVarBndr ()]
tvs Maybe Type
forall a. Maybe a
Nothing
    [Name -> [(Name, Bang, Type)] -> Con
TH.RecC Name
xlateName ([(Name, Bang, Type)] -> Con) -> [(Name, Bang, Type)] -> Con
forall a b. (a -> b) -> a -> b
$ [(Name, Bang, Type)]
holes [(Name, Bang, Type)]
-> [(Name, Bang, Type)] -> [(Name, Bang, Type)]
forall a. [a] -> [a] -> [a]
++ [(Name, Bang, Type)]
overrides]
    []
  where
  xlateName :: Name
xlateName = String -> Name
TH.mkName String
"XlateI"
  tvs :: [TyVarBndr ()]
tvs = (Name -> () -> TyVarBndr ()) -> () -> Name -> TyVarBndr ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV () (Name -> TyVarBndr ()) -> [Name] -> [TyVarBndr ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XlateDef -> [Name]
xlateParams XlateDef
x

declareXlateLifter :: XlateDef -> Q [Dec]
declareXlateLifter :: XlateDef -> Q [Dec]
declareXlateLifter XlateDef
x = do
  let liftName :: Name
liftName = String -> Name
TH.mkName String
"idXlate"
  Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
TH.putDoc (Name -> DocLoc
TH.DeclDoc Name
liftName) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ String
"This function is used by Nanopass to implement the @descend\\<Syntactic Category\\>I@ functions."
    , String
"It is used only to lift a pure 'XlateI' parameter into an 'Xlate'."
    , String
"This way, pure translations can use the same code paths as the more general 'Control.Applicative.Applicative' translations."
    , String
"Internally, it just arranges wrapping and unwrapping of t'Data.Functor.Identity.Identity', which are no-ops."
    ]
  let quantifier :: [TyVarBndr Specificity]
quantifier = (Name -> Specificity -> TyVarBndr Specificity)
-> Specificity -> Name -> TyVarBndr Specificity
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV Specificity
TH.InferredSpec (Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XlateDef
x.xlateParams
      xlateApTyCon :: Type
xlateApTyCon = Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
"Xlate"
      xlateApTy :: Type
xlateApTy = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
xlateApTyCon ((Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XlateDef
x.xlateParams) [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Name -> Type
TH.ConT ''Identity])
      xlateIdTyCon :: Type
xlateIdTyCon = Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
"XlateI"
      xlateIdTy :: Type
xlateIdTy = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
xlateIdTyCon (Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XlateDef
x.xlateParams)
  Name
xlateVar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"xlate"
  [(Name, Exp)]
holeMembers <- Name -> Q [(Name, Exp)]
forall {m :: * -> *}. Quote m => Name -> m [(Name, Exp)]
holes Name
xlateVar
  [(Name, Exp)]
ovrMembers <- Name -> Q [(Name, Exp)]
forall {m :: * -> *}. Quote m => Name -> m [(Name, Exp)]
overrides Name
xlateVar
  let body :: Exp
body = Name -> [(Name, Exp)] -> Exp
TH.RecConE (String -> Name
TH.mkName String
"Xlate") ([(Name, Exp)]
holeMembers [(Name, Exp)] -> [(Name, Exp)] -> [(Name, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Name, Exp)]
ovrMembers)
      clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Name -> Pat
TH.VarP Name
xlateVar] (Exp -> Body
TH.NormalB Exp
body) []
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Name -> Type -> Dec
TH.SigD Name
liftName (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity] -> [Type] -> Type -> Type
TH.ForallT [TyVarBndr Specificity]
quantifier [] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
        Type
xlateIdTy Type -> Type -> Type
`ArrT` Type
xlateApTy
    , Name -> [Clause] -> Dec
TH.FunD Name
liftName [Clause
clause]
    ]
  where
  holes :: Name -> m [(Name, Exp)]
holes Name
xlateVar = [XlateHoleDef]
-> (XlateHoleDef -> m (Name, Exp)) -> m [(Name, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Either XlateHoleDef XlateAuto] -> [XlateHoleDef]
forall a b. [Either a b] -> [a]
lefts XlateDef
x.xlateProds) ((XlateHoleDef -> m (Name, Exp)) -> m [(Name, Exp)])
-> (XlateHoleDef -> m (Name, Exp)) -> m [(Name, Exp)]
forall a b. (a -> b) -> a -> b
$ \XlateHoleDef
hole -> do
    let nameAp :: Name
nameAp = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead XlateHoleDef
hole.syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateHoleDef
hole.prodName
        nameId :: Name
nameId = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead XlateHoleDef
hole.syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ XlateHoleDef
hole.prodName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"I"
    [Name]
subtermNames <- [Type] -> (Type -> m Name) -> m [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM XlateHoleDef
hole.holeArgs ((Type -> m Name) -> m [Name]) -> (Type -> m Name) -> m [Name]
forall a b. (a -> b) -> a -> b
$ \Type
_ -> do
      String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"subterm"
    let lam :: Exp
lam = [Pat] -> Exp -> Exp
TH.LamE (Name -> Pat
TH.VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
subtermNames) Exp
body
        body :: Exp
body = Name -> Exp
TH.ConE 'Identity Exp -> Exp -> Exp
`AppE` (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE Exp
delegate (Name -> Exp
TH.VarE (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
subtermNames)
        delegate :: Exp
delegate = Name -> Exp
TH.VarE Name
nameId Exp -> Exp -> Exp
`AppE` Name -> Exp
TH.VarE Name
xlateVar
    (Name, Exp) -> m (Name, Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
nameAp, Exp
lam)
  overrides :: Name -> m [(Name, Exp)]
overrides Name
xlateVar = [XlateSyncatDef]
-> (XlateSyncatDef -> m (Name, Exp)) -> m [(Name, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM XlateDef
x.xlateSyncats ((XlateSyncatDef -> m (Name, Exp)) -> m [(Name, Exp)])
-> (XlateSyncatDef -> m (Name, Exp)) -> m [(Name, Exp)]
forall a b. (a -> b) -> a -> b
$ \XlateSyncatDef
syncat -> do
    let nameAp :: Name
nameAp = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead XlateSyncatDef
syncat.syncatName
        nameId :: Name
nameId = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead XlateSyncatDef
syncat.syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"I"
    Name
varName <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"term0"
    let lam :: Exp
lam = [Pat] -> Exp -> Exp
TH.LamE [Name -> Pat
TH.VarP Name
varName] Exp
body
        body :: Exp
body = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.ConE 'Identity) (Name -> Exp
TH.VarE '(<$>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
delegate)
        delegate :: Exp
delegate = (Name -> Exp
TH.VarE Name
nameId Exp -> Exp -> Exp
`AppE` Name -> Exp
TH.VarE Name
xlateVar) Exp -> Exp -> Exp
`AppE` Name -> Exp
TH.VarE Name
varName
    (Name, Exp) -> m (Name, Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
nameAp, Exp
lam)

interpretTypeDesc :: DefdLang -> TypeDesc -> TH.Type
interpretTypeDesc :: DefdLang -> TypeDesc -> Type
interpretTypeDesc DefdLang
l = TypeDesc -> Type
go
  where
  go :: TypeDesc -> Type
go (RecursiveType String
sName) =
    let syncatCtor :: Type
syncatCtor = Name -> Type
TH.ConT (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DefdLang
l.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sName)
     in (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
syncatCtor (Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefdLang
l.defdLangParams)
  go (VarType Name
vName) = Name -> Type
TH.VarT Name
vName
  go (CtorType Name
thName [TypeDesc]
argDescs) = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
TH.ConT Name
thName) (TypeDesc -> Type
go (TypeDesc -> Type) -> [TypeDesc] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDesc]
argDescs)
  go (ListType TypeDesc
argDesc) = Type -> Type -> Type
AppT Type
TH.ListT (TypeDesc -> Type
go TypeDesc
argDesc)
  go (NonEmptyType TypeDesc
argDesc) = Type -> Type -> Type
AppT (Name -> Type
TH.ConT ''NonEmpty) (TypeDesc -> Type
go TypeDesc
argDesc)
  go (MaybeType TypeDesc
argDesc) = Type -> Type -> Type
AppT (Name -> Type
TH.ConT ''Maybe) (TypeDesc -> Type
go TypeDesc
argDesc)
  go (TupleType TypeDesc
t1 TypeDesc
t2 [TypeDesc]
ts) =
    let tupLen :: Int
tupLen = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [TypeDesc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeDesc]
ts
        thTup :: Type
thTup = Int -> Type
TH.TupleT Int
tupLen
        tys :: [Type]
tys = TypeDesc -> Type
go (TypeDesc -> Type) -> [TypeDesc] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeDesc
t1TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:TypeDesc
t2TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:[TypeDesc]
ts)
     in (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
thTup [Type]
tys
  go (MapType TypeDesc
kDesc TypeDesc
vDesc) = do
    let m :: Type
m = Name -> Type
TH.ConT ''Map
        k :: Type
k = TypeDesc -> Type
go TypeDesc
kDesc
        v :: Type
v = TypeDesc -> Type
go TypeDesc
vDesc
     in Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
m Type
k) Type
v


---------------------------------------
------ Declare Descend Functions ------
---------------------------------------

defineDescend :: DefdLang -> DefdLang -> XlateDef -> Q [Dec]
defineDescend :: DefdLang -> DefdLang -> XlateDef -> Q [Dec]
defineDescend DefdLang
l1 DefdLang
l2 XlateDef
xdef = do
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ((XlateSyncatDef -> Q [Dec]) -> Q [[Dec]])
-> (XlateSyncatDef -> Q [Dec])
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XlateSyncatDef] -> (XlateSyncatDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM XlateDef
xdef.xlateSyncats ((XlateSyncatDef -> Q [Dec]) -> Q [Dec])
-> (XlateSyncatDef -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \XlateSyncatDef{String
syncatName :: String
$sel:syncatName:XlateSyncatDef :: XlateSyncatDef -> String
syncatName} -> do
    let funName :: Name
funName = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"descend" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
syncatName
        funNameId :: Name
funNameId = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"descend" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"I"
    Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
TH.putDoc (Name -> DocLoc
TH.DeclDoc Name
funName) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ [String] -> String
unwords
        [ String
"Translate syntax trees starting from"
        , String
"any t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DefdLang
l1.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' of the t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show DefdLang
l1.defdLangName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' language"
        , String
"to the corresponding '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DefdLang
l2.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' of the t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show DefdLang
l2.defdLangName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' language."
        ]
      , String
""
      , String
"Some (hopefully most) of this function was automatically generated by nanopass."
      , [String] -> String
unwords
        [ String
"It is parameterized by an t'Xlate', which"
        , String
"fills holes for which nanopass could not automatcially determine a translation, and also"
        , String
"allows for automatic translation to be overridden."
        ]
      ]
    Q () -> Q ()
TH.addModFinalizer (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ DocLoc -> String -> Q ()
TH.putDoc (Name -> DocLoc
TH.DeclDoc Name
funNameId) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ [String] -> String
unwords
        [ String
"Translate syntax trees starting from"
        , String
"any t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DefdLang
l1.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' of the t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show DefdLang
l1.defdLangName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' language"
        , String
"to the corresponding '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DefdLang
l2.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' of the t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show DefdLang
l2.defdLangName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' language."
        ]
      , String
""
      , String
"This is the pure (i.e. no 'Applicative' required) version of '"String -> String -> String
forall a. [a] -> [a] -> [a]
++Name -> String
forall a. Show a => a -> String
show Name
funNameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'."
      , String
"This version is parameterized by an t'XlateI' rather than an t'Xlate'."
      , String
"See '"String -> String -> String
forall a. [a] -> [a] -> [a]
++Name -> String
forall a. Show a => a -> String
show Name
funNameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' for more details."
      ]
    Name
xlateVar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"xlate"
    Name
termVar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"term"
    -- define the automatic case matching
    [Match]
autoMatches <- case String -> Map String DefdSyncatType -> Maybe DefdSyncatType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
syncatName DefdLang
l1.defdSyncats of
      Maybe DefdSyncatType
Nothing -> String -> Q [Match]
forall a. String -> a
errorWithoutStackTrace (String -> Q [Match]) -> String -> Q [Match]
forall a b. (a -> b) -> a -> b
$ String
"nanopass internal error: failed to find a source syncat that appears as an override: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
syncatName
      Just DefdSyncatType{Map String DefdProd
defdProds :: DefdSyncatType -> Map String DefdProd
defdProds :: Map String DefdProd
defdProds} -> do
        -- go through all the productions for this syntactic category's type
        [(String, DefdProd)]
-> ((String, DefdProd) -> Q Match) -> Q [Match]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map String DefdProd -> [(String, DefdProd)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map String DefdProd
defdProds) (((String, DefdProd) -> Q Match) -> Q [Match])
-> ((String, DefdProd) -> Q Match) -> Q [Match]
forall a b. (a -> b) -> a -> b
$ \(String
_, DefdProd
prod) -> do
          let pName :: String
pName = Name -> String
TH.nameBase DefdProd
prod.defdProdName
          [Name]
args <- (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String -> Q Name)
-> (DefdSubterm -> String) -> DefdSubterm -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
TH.nameBase (Name -> String) -> (DefdSubterm -> Name) -> DefdSubterm -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefdSubterm -> Name
defdSubtermName) (DefdSubterm -> Q Name) -> [DefdSubterm] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` DefdProd
prod.defdSubterms
          let pat :: Pat
pat = Name -> [Type] -> [Pat] -> Pat
TH.ConP DefdProd
prod.defdProdName [] (Name -> Pat
TH.VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
          let body :: Exp
body = case String
-> String
-> [Either XlateHoleDef XlateAuto]
-> Maybe (Either XlateHoleDef XlateAuto)
findAuto String
syncatName String
pName XlateDef
xdef.xlateProds of
                -- if this production has a hole, call the hole
                Just (Left XlateHoleDef
_) ->
                  let f :: Name
f = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead String
syncatName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pName
                      recurse :: Exp
recurse = Name -> Exp
VarE Name
f Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
xlateVar
                   in (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE Exp
recurse (Name -> Exp
VarE (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)
                Just (Right XlateAuto
auto) ->
                  let e0 :: Exp
e0 = Name -> Exp
VarE 'pure Exp -> Exp -> Exp
`AppE` Name -> Exp
TH.ConE (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DefdLang
l2.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pName)
                      iAppE :: Exp -> Exp -> Exp
iAppE Exp
a Exp
b = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
a) (Name -> Exp
VarE '(<*>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
b)
                      es :: [Exp]
es = ((Name -> Exp) -> Name -> Exp) -> [Name -> Exp] -> [Name] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
($) (XlateAuto
auto.autoArgs [Name -> Name -> Exp]
-> ((Name -> Name -> Exp) -> Name -> Exp) -> [Name -> Exp]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((Name -> Name -> Exp) -> Name -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Name
xlateVar)) [Name]
args
                   in (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
iAppE Exp
e0 [Exp]
es
                Maybe (Either XlateHoleDef XlateAuto)
Nothing -> String -> Exp
forall a. HasCallStack => String -> a
error String
"internal nanopass error: found neither hole nor auto"
          Match -> Q Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
TH.Match Pat
pat (Exp -> Body
TH.NormalB Exp
body) []
    let autoBody :: Exp
autoBody = Exp -> [Match] -> Exp
TH.CaseE (Name -> Exp
VarE Name
termVar) [Match]
autoMatches
    -- define the case match on the result of the override
    Name
termVar' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"term"
    let override :: Exp
override = Name -> Exp
VarE (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
lowerHead String
syncatName)
                   Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE Name
xlateVar)
                   Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE Name
termVar)
        ovrMatches :: [Match]
ovrMatches =
          [ Pat -> Body -> [Dec] -> Match
TH.Match (Name -> [Type] -> [Pat] -> Pat
TH.ConP 'Just [] [Name -> Pat
TH.VarP Name
termVar']) (Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
termVar') []
          , Pat -> Body -> [Dec] -> Match
TH.Match (Name -> [Type] -> [Pat] -> Pat
TH.ConP 'Nothing [] []) (Exp -> Body
TH.NormalB Exp
autoBody) []
          ]
    -- tie it all together
    let body :: Exp
body = Exp -> [Match] -> Exp
TH.CaseE Exp
override [Match]
ovrMatches
        clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Name -> Pat
TH.VarP Name
xlateVar, Name -> Pat
TH.VarP Name
termVar] (Exp -> Body
TH.NormalB Exp
body) []
    let delegateId :: Exp
delegateId = Name -> Exp
TH.VarE Name
funName Exp -> Exp -> Exp
`AppE` (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"idXlate") Exp -> Exp -> Exp
`AppE` Name -> Exp
TH.VarE Name
xlateVar)
        bodyId :: Exp
bodyId = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE 'runIdentity) (Name -> Exp
TH.VarE '(.)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
delegateId)
        clauseId :: Clause
clauseId = [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Name -> Pat
TH.VarP Name
xlateVar] (Exp -> Body
TH.NormalB Exp
bodyId) []
    -- generate a type signature
    let quantifier :: [TyVarBndr Specificity]
quantifier = (Name -> Specificity -> TyVarBndr Specificity)
-> Specificity -> Name -> TyVarBndr Specificity
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV Specificity
TH.InferredSpec (Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XlateDef
xdef.xlateParams [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [XlateDef
xdef.xlateFParam]
        appClass :: Type
appClass = Name -> Type
TH.ConT ''Applicative Type -> Type -> Type
`AppT` Name -> Type
TH.VarT XlateDef
xdef.xlateFParam
        xlateArgTyCon :: Type
xlateArgTyCon = Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
"Xlate"
        xlateArgTy :: Type
xlateArgTy = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
xlateArgTyCon (Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XlateDef
xdef.xlateParams [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [XlateDef
xdef.xlateFParam])
        l1ArgTyCon :: Type
l1ArgTyCon = Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DefdLang
l1.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
syncatName
        l1ArgTy :: Type
l1ArgTy = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
l1ArgTyCon (Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefdLang
l1.defdLangParams)
        l2ResTyCon :: Type
l2ResTyCon = Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ DefdLang
l2.langQualPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
syncatName
        l2ResTyCore :: Type
l2ResTyCore = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
l2ResTyCon (Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefdLang
l2.defdLangParams)
        l2ResTy :: Type
l2ResTy = Type -> Type -> Type
AppT (Name -> Type
TH.VarT XlateDef
xdef.xlateFParam) Type
l2ResTyCore
    let quantifierId :: [TyVarBndr Specificity]
quantifierId = (Name -> Specificity -> TyVarBndr Specificity)
-> Specificity -> Name -> TyVarBndr Specificity
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV Specificity
TH.InferredSpec (Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XlateDef
xdef.xlateParams
        xlateArgTyConId :: Type
xlateArgTyConId = Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
"XlateI"
        xlateArgTyId :: Type
xlateArgTyId = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
xlateArgTyConId (Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XlateDef
xdef.xlateParams)
        l2ResTyId :: Type
l2ResTyId = Type
l2ResTyCore
    -- and emit both signature and definition
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [ Name -> Type -> Dec
TH.SigD Name
funName (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity] -> [Type] -> Type -> Type
TH.ForallT [TyVarBndr Specificity]
quantifier [Type
appClass] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          Type
xlateArgTy Type -> Type -> Type
`ArrT` (Type
l1ArgTy Type -> Type -> Type
`ArrT` Type
l2ResTy)
      , Name -> [Clause] -> Dec
TH.FunD Name
funName [Clause
clause]
      -- the "pure" (i.e. non-applicative) version
      , Name -> Type -> Dec
TH.SigD Name
funNameId (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity] -> [Type] -> Type -> Type
TH.ForallT [TyVarBndr Specificity]
quantifierId [] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          Type
xlateArgTyId Type -> Type -> Type
`ArrT` (Type
l1ArgTy Type -> Type -> Type
`ArrT` Type
l2ResTyId)
      , Name -> [Clause] -> Dec
TH.FunD Name
funNameId [Clause
clauseId]
      ]

---------------------
------ Helpers ------
---------------------

pattern ArrT :: TH.Type -> TH.Type -> TH.Type
pattern $bArrT :: Type -> Type -> Type
$mArrT :: forall {r}. Type -> (Type -> Type -> r) -> ((# #) -> r) -> r
ArrT a b = AppT (AppT TH.ArrowT a) b

idiomAppE :: Exp -> Exp -> Exp
idiomAppE :: Exp -> Exp -> Exp
idiomAppE Exp
a Exp
b = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
a) (Name -> Exp
VarE '(<*>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
b)

noBang :: TH.Bang
noBang :: Bang
noBang = SourceUnpackedness -> SourceStrictness -> Bang
TH.Bang SourceUnpackedness
TH.NoSourceUnpackedness SourceStrictness
TH.NoSourceStrictness

containsGrammar :: TypeDesc -> Bool
containsGrammar :: TypeDesc -> Bool
containsGrammar (RecursiveType String
_) = Bool
True
containsGrammar (VarType Name
_) = Bool
False
containsGrammar (CtorType Name
_ [TypeDesc]
ts) = (TypeDesc -> Bool) -> [TypeDesc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypeDesc -> Bool
containsGrammar [TypeDesc]
ts
containsGrammar (ListType TypeDesc
t) = TypeDesc -> Bool
containsGrammar TypeDesc
t
containsGrammar (MaybeType TypeDesc
t) = TypeDesc -> Bool
containsGrammar TypeDesc
t
containsGrammar (NonEmptyType TypeDesc
t) = TypeDesc -> Bool
containsGrammar TypeDesc
t
containsGrammar (TupleType TypeDesc
t1 TypeDesc
t2 [TypeDesc]
ts) = (TypeDesc -> Bool) -> [TypeDesc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypeDesc -> Bool
containsGrammar (TypeDesc
t1TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:TypeDesc
t2TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:[TypeDesc]
ts)
containsGrammar (MapType TypeDesc
t1 TypeDesc
t2) = TypeDesc -> Bool
containsGrammar TypeDesc
t1 Bool -> Bool -> Bool
|| TypeDesc -> Bool
containsGrammar TypeDesc
t2

findAuto :: String -> String -> [XlateProd] -> Maybe XlateProd
findAuto :: String
-> String
-> [Either XlateHoleDef XlateAuto]
-> Maybe (Either XlateHoleDef XlateAuto)
findAuto String
sName String
pName [Either XlateHoleDef XlateAuto]
autosHoles = case (Either XlateHoleDef XlateAuto -> Bool)
-> [Either XlateHoleDef XlateAuto]
-> [Either XlateHoleDef XlateAuto]
forall a. (a -> Bool) -> [a] -> [a]
filter Either XlateHoleDef XlateAuto -> Bool
f [Either XlateHoleDef XlateAuto]
autosHoles of
  [] -> Maybe (Either XlateHoleDef XlateAuto)
forall a. Maybe a
Nothing
  Either XlateHoleDef XlateAuto
x:[Either XlateHoleDef XlateAuto]
_ -> Either XlateHoleDef XlateAuto
-> Maybe (Either XlateHoleDef XlateAuto)
forall a. a -> Maybe a
Just Either XlateHoleDef XlateAuto
x
  where
  f :: XlateProd -> Bool
  f :: Either XlateHoleDef XlateAuto -> Bool
f (Left XlateHoleDef
x) = XlateHoleDef
x.syncatName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
sName Bool -> Bool -> Bool
&& XlateHoleDef
x.prodName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pName
  f (Right XlateAuto
x) = XlateAuto
x.syncatName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
sName Bool -> Bool -> Bool
&& XlateAuto
x.prodName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pName


lowerHead :: String -> String
lowerHead :: String -> String
lowerHead [] = []
lowerHead (Char
c:String
cs) = Char -> Char
Char.toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs

hoistNothing :: Monad m => MaybeT m a
hoistNothing :: forall (m :: * -> *) a. Monad m => MaybeT m a
hoistNothing = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a) -> m (Maybe a) -> MaybeT m a
forall a b. (a -> b) -> a -> b
$ Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing