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

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

import Nanopass.Internal.Representation

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 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.Map as Map
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH


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

declareXlate :: Language 'Valid UpDotName -> Language 'Valid UpDotName -> XlateDef -> Q [Dec]
declareXlate :: Language 'Valid UpDotName
-> Language 'Valid UpDotName -> XlateDef -> Q [Dec]
declareXlate Language 'Valid UpDotName
l1 Language 'Valid UpDotName
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 <- Language 'Valid UpDotName
-> Language 'Valid UpDotName -> XlateDef -> Q [Dec]
defineDescend Language 'Valid UpDotName
l1 Language 'Valid UpDotName
l2 XlateDef
xlate
  [Dec] -> Q [Dec]
forall a. a -> Q a
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 -> [XlateNontermDef]
xlateNonterms :: [XlateNontermDef]
    -- ^ 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 xlateNonterms, 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 -> Language 'Valid UpDotName
xlateFrom :: Language 'Valid UpDotName
  , XlateDef -> Language 'Valid UpDotName
xlateTo :: Language 'Valid UpDotName
  }
type XlateProd = Either XlateHoleDef XlateAuto
data XlateAuto = XlateAuto
  { XlateAuto -> UpName
nontermName :: UpName
  , XlateAuto -> UpName
prodName :: UpName
  , XlateAuto -> [Name -> Name -> Exp]
autoArgs :: [TH.Name -> TH.Name -> Exp] -- functions from xlate and subterm variables to auto-translator
  }
data XlateHoleDef = XlateHoleDef
  { XlateHoleDef -> UpName
nontermName :: UpName -- the name of the syntactic category shared by source and target
  , XlateHoleDef -> UpName
prodName :: UpName -- 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 XlateNontermDef = XlateNontermDef
  { XlateNontermDef -> UpName
nontermName :: UpName -- the name of the syntactic category shared by source and target
  , XlateNontermDef -> Type
fromType :: TH.Type -- parameterized type of the source language at this syntactic category
  , XlateNontermDef -> Type
toType :: TH.Type -- parameterized type of the target language at this syntactic category
  }

xlateDef :: Language 'Valid UpDotName -> Language 'Valid UpDotName -> Q XlateDef
xlateDef :: Language 'Valid UpDotName
-> Language 'Valid UpDotName -> Q XlateDef
xlateDef Language 'Valid UpDotName
l1 Language 'Valid UpDotName
l2 = do
  let xlateParams :: [Name]
xlateParams = (.th) (Name 'Valid LowName -> Name) -> [Name 'Valid LowName] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name 'Valid LowName] -> [Name 'Valid LowName]
forall a. Eq a => [a] -> [a]
nub (Language 'Valid UpDotName
l1.langInfo.langParams [Name 'Valid LowName]
-> [Name 'Valid LowName] -> [Name 'Valid LowName]
forall a. [a] -> [a] -> [a]
++ Language 'Valid UpDotName
l2.langInfo.langParams)
  Name
xlateFParam <- if String -> Name
TH.mkName String
"f" Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> 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 a. a -> Q a
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 a b. (a -> b) -> Q a -> Q b
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
$ [(UpName, Nonterm 'Valid)]
-> ((UpName, Nonterm 'Valid) -> 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 UpName (Nonterm 'Valid) -> [(UpName, Nonterm 'Valid)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map UpName (Nonterm 'Valid) -> [(UpName, Nonterm 'Valid)])
-> Map UpName (Nonterm 'Valid) -> [(UpName, Nonterm 'Valid)]
forall a b. (a -> b) -> a -> b
$ Language 'Valid UpDotName
l1.langInfo.nonterms) (((UpName, Nonterm 'Valid) -> Q [Either XlateHoleDef XlateAuto])
 -> Q [[Either XlateHoleDef XlateAuto]])
-> ((UpName, Nonterm 'Valid) -> Q [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
forall a b. (a -> b) -> a -> b
$ Language 'Valid UpDotName
-> Language 'Valid UpDotName
-> (UpName, Nonterm 'Valid)
-> Q [Either XlateHoleDef XlateAuto]
detectHoles Language 'Valid UpDotName
l1 Language 'Valid UpDotName
l2
  let xlateNonterms :: [XlateNontermDef]
xlateNonterms = ((UpName, Nonterm 'Valid) -> [XlateNontermDef])
-> [(UpName, Nonterm 'Valid)] -> [XlateNontermDef]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Language 'Valid UpDotName
-> Language 'Valid UpDotName
-> (UpName, Nonterm 'Valid)
-> [XlateNontermDef]
detectOverrides Language 'Valid UpDotName
l1 Language 'Valid UpDotName
l2) ([(UpName, Nonterm 'Valid)] -> [XlateNontermDef])
-> [(UpName, Nonterm 'Valid)] -> [XlateNontermDef]
forall a b. (a -> b) -> a -> b
$ Map UpName (Nonterm 'Valid) -> [(UpName, Nonterm 'Valid)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Language 'Valid UpDotName
l1.langInfo.nonterms
  XlateDef -> Q XlateDef
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XlateDef -> Q XlateDef) -> XlateDef -> Q XlateDef
forall a b. (a -> b) -> a -> b
$ XlateDef
    { [Name]
$sel:xlateParams:XlateDef :: [Name]
xlateParams :: [Name]
xlateParams
    , Name
$sel:xlateFParam:XlateDef :: Name
xlateFParam :: Name
xlateFParam
    , [XlateNontermDef]
$sel:xlateNonterms:XlateDef :: [XlateNontermDef]
xlateNonterms :: [XlateNontermDef]
xlateNonterms
    , [Either XlateHoleDef XlateAuto]
$sel:xlateProds:XlateDef :: [Either XlateHoleDef XlateAuto]
xlateProds :: [Either XlateHoleDef XlateAuto]
xlateProds
    , $sel:xlateFrom:XlateDef :: Language 'Valid UpDotName
xlateFrom = Language 'Valid UpDotName
l1
    , $sel:xlateTo:XlateDef :: Language 'Valid UpDotName
xlateTo = Language 'Valid UpDotName
l2
    }

detectHoles :: Language 'Valid UpDotName
            -> Language 'Valid UpDotName
            -> (UpName, Nonterm 'Valid)
            -> Q [Either XlateHoleDef XlateAuto]
detectHoles :: Language 'Valid UpDotName
-> Language 'Valid UpDotName
-> (UpName, Nonterm 'Valid)
-> Q [Either XlateHoleDef XlateAuto]
detectHoles Language 'Valid UpDotName
l1 Language 'Valid UpDotName
l2 (UpName
sName, Nonterm 'Valid
s1) = case UpName -> Map UpName (Nonterm 'Valid) -> Maybe (Nonterm 'Valid)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpName
sName Language 'Valid UpDotName
l2.langInfo.nonterms of
  Maybe (Nonterm 'Valid)
Nothing -> [Either XlateHoleDef XlateAuto]
-> Q [Either XlateHoleDef XlateAuto]
forall a. a -> Q a
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 Nonterm 'Valid
s2 -> ([[Either XlateHoleDef XlateAuto]]
 -> [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
-> Q [Either XlateHoleDef XlateAuto]
forall a b. (a -> b) -> Q a -> Q b
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
$ [(UpName, Production 'Valid)]
-> ((UpName, Production 'Valid)
    -> 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 UpName (Production 'Valid) -> [(UpName, Production 'Valid)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Nonterm 'Valid
s1.productions) (((UpName, Production 'Valid) -> Q [Either XlateHoleDef XlateAuto])
 -> Q [[Either XlateHoleDef XlateAuto]])
-> ((UpName, Production 'Valid)
    -> Q [Either XlateHoleDef XlateAuto])
-> Q [[Either XlateHoleDef XlateAuto]]
forall a b. (a -> b) -> a -> b
$ Nonterm 'Valid
-> (UpName, Production 'Valid) -> Q [Either XlateHoleDef XlateAuto]
detectHoleCtors Nonterm 'Valid
s2
  where
  detectHoleCtors :: Nonterm 'Valid -> (UpName, Production 'Valid) -> Q [Either XlateHoleDef XlateAuto]
  detectHoleCtors :: Nonterm 'Valid
-> (UpName, Production 'Valid) -> Q [Either XlateHoleDef XlateAuto]
detectHoleCtors Nonterm 'Valid
s2 (UpName
pName, Production 'Valid
prod1) = case UpName
-> Map UpName (Production 'Valid) -> Maybe (Production 'Valid)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpName
pName Nonterm 'Valid
s2.productions of
    -- a required hole, because there is no constructor to target
    Maybe (Production 'Valid)
Nothing -> [Either XlateHoleDef XlateAuto]
-> Q [Either XlateHoleDef XlateAuto]
forall a. a -> Q a
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
$ UpName -> Production 'Valid -> XlateHoleDef
createHole UpName
pName Production 'Valid
prod1]
    Just Production 'Valid
prod2
      -- no custom translation required: the arguments of one constructor match up with the arguments of the other
      | [TypeDesc 'Valid]
tys1 <- Production 'Valid
prod1.subterms
      , [TypeDesc 'Valid]
tys2 <- Production 'Valid
prod2.subterms
      , [TypeDesc 'Valid]
tys1 [TypeDesc 'Valid] -> [TypeDesc 'Valid] -> Bool
forall a. Eq a => a -> a -> Bool
== [TypeDesc 'Valid]
tys2 -> MaybeT Q [Name -> Name -> Exp] -> Q (Maybe [Name -> Name -> Exp])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (TypeDesc 'Valid -> MaybeT Q (Name -> Name -> Exp)
createAuto (TypeDesc 'Valid -> MaybeT Q (Name -> Name -> Exp))
-> [TypeDesc 'Valid] -> MaybeT Q [Name -> Name -> Exp]
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` [TypeDesc 'Valid]
tys1) Q (Maybe [Name -> Name -> Exp])
-> (Maybe [Name -> Name -> Exp]
    -> Q [Either XlateHoleDef XlateAuto])
-> Q [Either XlateHoleDef XlateAuto]
forall a b. Q a -> (a -> Q b) -> Q b
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 a. a -> Q a
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
$ UpName -> Production 'Valid -> XlateHoleDef
createHole UpName
pName Production 'Valid
prod1] -- a required hole because no auto-translation possible
          Just [Name -> Name -> Exp]
autoArgs -> do
            [Either XlateHoleDef XlateAuto]
-> Q [Either XlateHoleDef XlateAuto]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [XlateAuto -> Either XlateHoleDef XlateAuto
forall a b. b -> Either a b
Right XlateAuto{$sel:nontermName:XlateAuto :: UpName
nontermName=UpName
sName,$sel:prodName:XlateAuto :: UpName
prodName=UpName
pName,[Name -> Name -> Exp]
$sel:autoArgs:XlateAuto :: [Name -> Name -> Exp]
autoArgs :: [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 a. a -> Q a
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
$ UpName -> Production 'Valid -> XlateHoleDef
createHole UpName
pName Production 'Valid
prod1]
  createHole :: UpName -> Production 'Valid -> XlateHoleDef
  createHole :: UpName -> Production 'Valid -> XlateHoleDef
createHole UpName
pName Production 'Valid
prod1 =
    let holeArgs :: [Type]
holeArgs = ((TypeDesc 'Valid -> Type) -> [TypeDesc 'Valid] -> [Type])
-> [TypeDesc 'Valid] -> (TypeDesc 'Valid -> Type) -> [Type]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TypeDesc 'Valid -> Type) -> [TypeDesc 'Valid] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Production 'Valid
prod1.subterms ((TypeDesc 'Valid -> Type) -> [Type])
-> (TypeDesc 'Valid -> Type) -> [Type]
forall a b. (a -> b) -> a -> b
$ \TypeDesc 'Valid
subterm ->
          Language 'Valid UpDotName -> TypeDesc 'Valid -> Type
interpretTypeDesc Language 'Valid UpDotName
l1 TypeDesc 'Valid
subterm
        holeCtor :: Type
holeCtor = Name -> Type
TH.ConT (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l2.langName.name UpName
sName))
        holeResult :: Type
holeResult = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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 'Valid LowName -> Name) -> Name 'Valid LowName -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.th) (Name 'Valid LowName -> Type) -> [Name 'Valid LowName] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Language 'Valid UpDotName
l2.langInfo.langParams)
     in XlateHoleDef{$sel:nontermName:XlateHoleDef :: UpName
nontermName=UpName
sName,$sel:prodName:XlateHoleDef :: UpName
prodName=UpName
pName,[Type]
$sel:holeArgs:XlateHoleDef :: [Type]
holeArgs :: [Type]
holeArgs,Type
$sel:holeResult:XlateHoleDef :: Type
holeResult :: Type
holeResult}

detectOverrides :: Language 'Valid UpDotName -> Language 'Valid UpDotName -> (UpName, Nonterm 'Valid) -> [XlateNontermDef]
detectOverrides :: Language 'Valid UpDotName
-> Language 'Valid UpDotName
-> (UpName, Nonterm 'Valid)
-> [XlateNontermDef]
detectOverrides Language 'Valid UpDotName
l1 Language 'Valid UpDotName
l2 (UpName
sName, Nonterm 'Valid
_) = case UpName -> Map UpName (Nonterm 'Valid) -> Maybe (Nonterm 'Valid)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpName
sName Language 'Valid UpDotName
l2.langInfo.nonterms of
  Maybe (Nonterm 'Valid)
Nothing -> [] -- no translation required: no l2 ctor can use the a type corresponding to this l1 type (because it doesn't exist)
  Just Nonterm 'Valid
_ ->
    let fromTypeCtor :: Type
fromTypeCtor = Name -> Type
TH.ConT (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l1.langName.name UpName
sName))
        fromType :: Type
fromType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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 'Valid LowName -> Name) -> Name 'Valid LowName -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.th) (Name 'Valid LowName -> Type) -> [Name 'Valid LowName] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Language 'Valid UpDotName
l1.langInfo.langParams)
        toTypeCtor :: Type
toTypeCtor = Name -> Type
TH.ConT (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l2.langName.name UpName
sName))
        toType :: Type
toType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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 'Valid LowName -> Name) -> Name 'Valid LowName -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.th) (Name 'Valid LowName -> Type) -> [Name 'Valid LowName] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Language 'Valid UpDotName
l2.langInfo.langParams)
     in [XlateNontermDef{$sel:nontermName:XlateNontermDef :: UpName
nontermName = UpName
sName,Type
$sel:fromType:XlateNontermDef :: Type
fromType :: Type
fromType,Type
$sel:toType:XlateNontermDef :: Type
toType :: Type
toType}]

createAuto :: TypeDesc 'Valid -> MaybeT Q (TH.Name -> TH.Name -> Exp)
createAuto :: TypeDesc 'Valid -> MaybeT Q (Name -> Name -> Exp)
createAuto (RecursiveType UpName
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]
++ UpName -> String
fromUpName UpName
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 a. a -> MaybeT Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
auto
createAuto (VarType Name 'Valid LowName
_) = 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 a. a -> MaybeT Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
forall {p}. p -> Name -> Exp
auto
createAuto (CtorType Name 'Valid UpDotName
tyName [TypeDesc 'Valid]
ts)
  | (TypeDesc 'Valid -> Bool) -> [TypeDesc 'Valid] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool)
-> (TypeDesc 'Valid -> Bool) -> TypeDesc 'Valid -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDesc 'Valid -> Bool
containsGrammar) [TypeDesc 'Valid]
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 a. a -> MaybeT Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
forall {p}. p -> Name -> Exp
auto
  | TypeDesc 'Valid
t:[TypeDesc 'Valid]
ts' <- [TypeDesc 'Valid] -> [TypeDesc 'Valid]
forall a. [a] -> [a]
reverse [TypeDesc 'Valid]
ts
  , (TypeDesc 'Valid -> Bool) -> [TypeDesc 'Valid] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool)
-> (TypeDesc 'Valid -> Bool) -> TypeDesc 'Valid -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDesc 'Valid -> Bool
containsGrammar) [TypeDesc 'Valid]
ts' = do
      let travCandidate :: Type
travCandidate = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
TH.ConT Name 'Valid UpDotName
tyName.th) (Language 'Valid UpDotName -> TypeDesc 'Valid -> Type
interpretTypeDesc (Name 'Valid UpDotName
-> LanguageInfo 'Valid -> Language 'Valid UpDotName
forall (v :: Validate) n.
Name v n -> LanguageInfo v -> Language v n
Language Name 'Valid UpDotName
forall a. HasCallStack => a
undefined LanguageInfo 'Valid
forall a. HasCallStack => a
undefined) (TypeDesc 'Valid -> Type) -> [TypeDesc 'Valid] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDesc 'Valid]
ts')
      Bool
isTraversable <- Q Bool -> MaybeT Q Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 'Valid -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc 'Valid
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 'Valid
t) = TypeDesc 'Valid -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc 'Valid
t
createAuto (MaybeType TypeDesc 'Valid
t) = TypeDesc 'Valid -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc 'Valid
t
createAuto (NonEmptyType TypeDesc 'Valid
t) = TypeDesc 'Valid -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc 'Valid
t
createAuto TypeDesc 'Valid
UnitType = do
  let auto :: p -> p -> Exp
auto p
_ p
_ = Name -> Exp
VarE 'pure Exp -> Exp -> Exp
`AppE` [Maybe Exp] -> Exp
TH.TupE []
  (Name -> Name -> Exp) -> MaybeT Q (Name -> Name -> Exp)
forall a. a -> MaybeT Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
forall {p} {p}. p -> p -> Exp
auto
createAuto (TupleType TypeDesc 'Valid
t1 TypeDesc 'Valid
t2 [TypeDesc 'Valid]
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 'Valid] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TypeDesc 'Valid
t1TypeDesc 'Valid -> [TypeDesc 'Valid] -> [TypeDesc 'Valid]
forall a. a -> [a] -> [a]
:TypeDesc 'Valid
t2TypeDesc 'Valid -> [TypeDesc 'Valid] -> [TypeDesc 'Valid]
forall a. a -> [a] -> [a]
:[TypeDesc 'Valid]
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 (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 a. a -> MaybeT Q a
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 a b. (a -> b) -> MaybeT Q a -> MaybeT Q b
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 'Valid)]
-> ((Int, TypeDesc 'Valid) -> 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 'Valid] -> [(Int, TypeDesc 'Valid)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
1::Int)..] (TypeDesc 'Valid
t1TypeDesc 'Valid -> [TypeDesc 'Valid] -> [TypeDesc 'Valid]
forall a. a -> [a] -> [a]
:TypeDesc 'Valid
t2TypeDesc 'Valid -> [TypeDesc 'Valid] -> [TypeDesc 'Valid]
forall a. a -> [a] -> [a]
:[TypeDesc 'Valid]
ts)) (((Int, TypeDesc 'Valid) -> MaybeT Q (Name, Name -> Name -> Exp))
 -> MaybeT Q [(Name, Name -> Name -> Exp)])
-> ((Int, TypeDesc 'Valid) -> MaybeT Q (Name, Name -> Name -> Exp))
-> MaybeT Q [(Name, Name -> Name -> Exp)]
forall a b. (a -> b) -> a -> b
$ \(Int
i, TypeDesc 'Valid
t) -> do
    Name -> Name -> Exp
auto' <- TypeDesc 'Valid -> MaybeT Q (Name -> Name -> Exp)
createAuto TypeDesc 'Valid
t
    Name
arg' <- Q Name -> MaybeT Q Name
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 a. a -> MaybeT Q a
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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> MaybeT Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name -> Name -> Exp
auto

traversableAuto :: TypeDesc 'Valid -> MaybeT Q (TH.Name -> TH.Name -> Exp)
traversableAuto :: TypeDesc 'Valid -> MaybeT Q (Name -> Name -> Exp)
traversableAuto TypeDesc 'Valid
t = do
  Name
var <- Q Name -> MaybeT Q Name
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
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 'Valid -> MaybeT Q (Name -> Name -> Exp)
createAuto TypeDesc 'Valid
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 a. a -> MaybeT Q a
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
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateHoleDef
hole.nontermName String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName 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 a b. (a -> b -> b) -> b -> [a] -> b
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'", UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase XlateDef
x.xlateFrom.langName.name XlateHoleDef
hole.prodName), String
"' production "
        , String
"of t'", UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase XlateDef
x.xlateFrom.langName.name XlateHoleDef
hole.nontermName), String
"'"
        ]
      , String
"could be generated by Nanopass."
      ]
    (Name, Bang, Type) -> Q (Name, Bang, Type)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Bang
bang, Type
t)
  [(Name, Bang, Type)]
overrides <- [XlateNontermDef]
-> (XlateNontermDef -> 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.xlateNonterms ((XlateNontermDef -> Q (Name, Bang, Type))
 -> Q [(Name, Bang, Type)])
-> (XlateNontermDef -> Q (Name, Bang, Type))
-> Q [(Name, Bang, Type)]
forall a b. (a -> b) -> a -> b
$ \XlateNontermDef
nonterm -> do
    let name :: Name
name = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateNontermDef
nonterm.nontermName
        r :: Type
r = Name -> Type
TH.ConT ''Maybe Type -> Type -> Type
`AppT` (Name -> Type
TH.VarT XlateDef
x.xlateFParam Type -> Type -> Type
`AppT` XlateNontermDef
nonterm.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]
++ UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase XlateDef
x.xlateFrom.langName.name XlateNontermDef
nonterm.nontermName) 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 a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Bang
bang, Type -> Type -> Type
ArrT XlateNontermDef
nonterm.fromType Type
r)
  Dec -> Q Dec
forall a. a -> Q a
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
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateHoleDef
hole.nontermName String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateHoleDef
hole.prodName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"I"
        t :: Type
t = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
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'", UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase XlateDef
x.xlateFrom.langName.name XlateHoleDef
hole.prodName), String
"' production "
        , String
"of t'", UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase XlateDef
x.xlateFrom.langName.name XlateHoleDef
hole.nontermName), String
"'"
        ]
      , String
"could be generated by Nanopass."
      ]
    (Name, Bang, Type) -> Q (Name, Bang, Type)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Bang
bang, Type
t)
  [(Name, Bang, Type)]
overrides <- [XlateNontermDef]
-> (XlateNontermDef -> 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.xlateNonterms ((XlateNontermDef -> Q (Name, Bang, Type))
 -> Q [(Name, Bang, Type)])
-> (XlateNontermDef -> Q (Name, Bang, Type))
-> Q [(Name, Bang, Type)]
forall a b. (a -> b) -> a -> b
$ \XlateNontermDef
nonterm -> do
    let name :: Name
name = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateNontermDef
nonterm.nontermName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"I"
        r :: Type
r = Name -> Type
TH.ConT ''Maybe Type -> Type -> Type
`AppT` XlateNontermDef
nonterm.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]
++ UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase XlateDef
x.xlateFrom.langName.name XlateNontermDef
nonterm.nontermName) 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 a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Bang
bang, Type -> Type -> Type
ArrT XlateNontermDef
nonterm.fromType Type
r)
  Dec -> Q Dec
forall a. a -> Q a
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 b a. (b -> a -> b) -> b -> [a] -> b
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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> Q a
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
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateHoleDef
hole.nontermName String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateHoleDef
hole.prodName
        nameId :: Name
nameId = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateHoleDef
hole.nontermName String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName 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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
nameAp, Exp
lam)
  overrides :: Name -> m [(Name, Exp)]
overrides Name
xlateVar = [XlateNontermDef]
-> (XlateNontermDef -> 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.xlateNonterms ((XlateNontermDef -> m (Name, Exp)) -> m [(Name, Exp)])
-> (XlateNontermDef -> m (Name, Exp)) -> m [(Name, Exp)]
forall a b. (a -> b) -> a -> b
$ \XlateNontermDef
nonterm -> do
    let nameAp :: Name
nameAp = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateNontermDef
nonterm.nontermName
        nameId :: Name
nameId = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName XlateNontermDef
nonterm.nontermName 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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
nameAp, Exp
lam)

interpretTypeDesc :: Language 'Valid UpDotName -> TypeDesc 'Valid -> TH.Type
interpretTypeDesc :: Language 'Valid UpDotName -> TypeDesc 'Valid -> Type
interpretTypeDesc Language 'Valid UpDotName
l = TypeDesc 'Valid -> Type
go
  where
  go :: TypeDesc 'Valid -> Type
go (RecursiveType UpName
sName) =
    let nontermCtor :: Type
nontermCtor = Name -> Type
TH.ConT (String -> Name
TH.mkName (String -> Name) -> (UpDotName -> String) -> UpDotName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpDotName -> String
fromUpDotName (UpDotName -> Name) -> UpDotName -> Name
forall a b. (a -> b) -> a -> b
$ UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l.langName.name UpName
sName)
     in (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
nontermCtor (Name -> Type
TH.VarT (Name -> Type)
-> (Name 'Valid LowName -> Name) -> Name 'Valid LowName -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.th) (Name 'Valid LowName -> Type) -> [Name 'Valid LowName] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Language 'Valid UpDotName
l.langInfo.langParams)
  go (VarType Name 'Valid LowName
vName) = Name -> Type
TH.VarT Name 'Valid LowName
vName.th
  go (CtorType Name 'Valid UpDotName
thName [TypeDesc 'Valid]
argDescs) = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
TH.ConT Name 'Valid UpDotName
thName.th) (TypeDesc 'Valid -> Type
go (TypeDesc 'Valid -> Type) -> [TypeDesc 'Valid] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDesc 'Valid]
argDescs)
  go (ListType TypeDesc 'Valid
argDesc) = Type -> Type -> Type
AppT Type
TH.ListT (TypeDesc 'Valid -> Type
go TypeDesc 'Valid
argDesc)
  go (NonEmptyType TypeDesc 'Valid
argDesc) = Type -> Type -> Type
AppT (Name -> Type
TH.ConT ''NonEmpty) (TypeDesc 'Valid -> Type
go TypeDesc 'Valid
argDesc)
  go (MaybeType TypeDesc 'Valid
argDesc) = Type -> Type -> Type
AppT (Name -> Type
TH.ConT ''Maybe) (TypeDesc 'Valid -> Type
go TypeDesc 'Valid
argDesc)
  go TypeDesc 'Valid
UnitType = Int -> Type
TH.TupleT Int
0
  go (TupleType TypeDesc 'Valid
t1 TypeDesc 'Valid
t2 [TypeDesc 'Valid]
ts) =
    let tupLen :: Int
tupLen = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [TypeDesc 'Valid] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeDesc 'Valid]
ts
        thTup :: Type
thTup = Int -> Type
TH.TupleT Int
tupLen
        tys :: [Type]
tys = TypeDesc 'Valid -> Type
go (TypeDesc 'Valid -> Type) -> [TypeDesc 'Valid] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeDesc 'Valid
t1TypeDesc 'Valid -> [TypeDesc 'Valid] -> [TypeDesc 'Valid]
forall a. a -> [a] -> [a]
:TypeDesc 'Valid
t2TypeDesc 'Valid -> [TypeDesc 'Valid] -> [TypeDesc 'Valid]
forall a. a -> [a] -> [a]
:[TypeDesc 'Valid]
ts)
     in (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
thTup [Type]
tys

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

defineDescend :: Language 'Valid UpDotName -> Language 'Valid UpDotName -> XlateDef -> Q [Dec]
defineDescend :: Language 'Valid UpDotName
-> Language 'Valid UpDotName -> XlateDef -> Q [Dec]
defineDescend Language 'Valid UpDotName
l1 Language 'Valid UpDotName
l2 XlateDef
xdef = do
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
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])
-> ((XlateNontermDef -> Q [Dec]) -> Q [[Dec]])
-> (XlateNontermDef -> Q [Dec])
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XlateNontermDef] -> (XlateNontermDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM XlateDef
xdef.xlateNonterms ((XlateNontermDef -> Q [Dec]) -> Q [Dec])
-> (XlateNontermDef -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \XlateNontermDef{UpName
$sel:nontermName:XlateNontermDef :: XlateNontermDef -> UpName
nontermName :: UpName
nontermName} -> 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]
++ UpName -> String
fromUpName UpName
nontermName
        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]
++ UpName -> String
fromUpName UpName
nontermName 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]
++ UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l1.langName.name UpName
nontermName) 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 Language 'Valid UpDotName
l1.langName.th String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' language"
        , String
"to the corresponding '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l2.langName.name UpName
nontermName) 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 Language 'Valid UpDotName
l2.langName.th 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]
++ UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l1.langName.name UpName
nontermName) 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 Language 'Valid UpDotName
l1.langName.th String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' language"
        , String
"to the corresponding '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpDotName -> String
fromUpDotName (UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l2.langName.name UpName
nontermName) 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 Language 'Valid UpDotName
l2.langName.th 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 UpName -> Map UpName (Nonterm 'Valid) -> Maybe (Nonterm 'Valid)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpName
nontermName Language 'Valid UpDotName
l1.langInfo.nonterms of
      Maybe (Nonterm 'Valid)
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 nonterm that appears as an override: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName UpName
nontermName
      Just Nonterm{Map UpName (Production 'Valid)
productions :: Map UpName (Production 'Valid)
$sel:productions:Nonterm :: forall (v :: Validate). Nonterm v -> Map UpName (Production v)
productions} -> do
        -- go through all the productions for this syntactic category's type
        [(UpName, Production 'Valid)]
-> ((UpName, Production 'Valid) -> Q Match) -> Q [Match]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map UpName (Production 'Valid) -> [(UpName, Production 'Valid)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map UpName (Production 'Valid)
productions) (((UpName, Production 'Valid) -> Q Match) -> Q [Match])
-> ((UpName, Production 'Valid) -> Q Match) -> Q [Match]
forall a b. (a -> b) -> a -> b
$ \(UpName
_, Production 'Valid
prod) -> do
          [Name]
args <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String -> Q Name) -> [String] -> Q [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` Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take ([TypeDesc 'Valid] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Production 'Valid
prod.subterms) [String]
base26
          let pat :: Pat
pat = Name -> [Type] -> [Pat] -> Pat
TH.ConP Production 'Valid
prod.prodName.th [] (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 UpName
-> UpName
-> [Either XlateHoleDef XlateAuto]
-> Maybe (Either XlateHoleDef XlateAuto)
findAuto UpName
nontermName Production 'Valid
prod.prodName.name 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
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName UpName
nontermName String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName Production 'Valid
prod.prodName.name
                      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 b a. (b -> a -> b) -> b -> [a] -> b
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) -> (UpDotName -> String) -> UpDotName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpDotName -> String
fromUpDotName (UpDotName -> Name) -> UpDotName -> Name
forall a b. (a -> b) -> a -> b
$ UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l2.langName.name Production 'Valid
prod.prodName.name)
                      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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> Q a
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
"on" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName UpName
nontermName)
                   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 b a. (b -> a -> b) -> b -> [a] -> b
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) -> (UpDotName -> String) -> UpDotName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpDotName -> String
fromUpDotName (UpDotName -> Name) -> UpDotName -> Name
forall a b. (a -> b) -> a -> b
$ UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l1.langName.name UpName
nontermName
        l1ArgTy :: Type
l1ArgTy = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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 'Valid LowName -> Name) -> Name 'Valid LowName -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.th) (Name 'Valid LowName -> Type) -> [Name 'Valid LowName] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Language 'Valid UpDotName
l1.langInfo.langParams)
        l2ResTyCon :: Type
l2ResTyCon = Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName (String -> Name) -> (UpDotName -> String) -> UpDotName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpDotName -> String
fromUpDotName (UpDotName -> Name) -> UpDotName -> Name
forall a b. (a -> b) -> a -> b
$ UpDotName -> UpName -> UpDotName
upDotChBase Language 'Valid UpDotName
l2.langName.name UpName
nontermName
        l2ResTyCore :: Type
l2ResTyCore = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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 'Valid LowName -> Name) -> Name 'Valid LowName -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.th) (Name 'Valid LowName -> Type) -> [Name 'Valid LowName] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Language 'Valid UpDotName
l2.langInfo.langParams)
        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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> Q a
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 $mArrT :: forall {r}. Type -> (Type -> Type -> r) -> ((# #) -> r) -> r
$bArrT :: Type -> Type -> Type
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)

bang :: TH.Bang
bang :: Bang
bang = SourceUnpackedness -> SourceStrictness -> Bang
TH.Bang SourceUnpackedness
TH.NoSourceUnpackedness SourceStrictness
TH.SourceStrict

containsGrammar :: TypeDesc 'Valid -> Bool
containsGrammar :: TypeDesc 'Valid -> Bool
containsGrammar (RecursiveType UpName
_) = Bool
True
containsGrammar (VarType Name 'Valid LowName
_) = Bool
False
containsGrammar (CtorType Name 'Valid UpDotName
_ [TypeDesc 'Valid]
ts) = (TypeDesc 'Valid -> Bool) -> [TypeDesc 'Valid] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypeDesc 'Valid -> Bool
containsGrammar [TypeDesc 'Valid]
ts
containsGrammar (ListType TypeDesc 'Valid
t) = TypeDesc 'Valid -> Bool
containsGrammar TypeDesc 'Valid
t
containsGrammar (MaybeType TypeDesc 'Valid
t) = TypeDesc 'Valid -> Bool
containsGrammar TypeDesc 'Valid
t
containsGrammar (NonEmptyType TypeDesc 'Valid
t) = TypeDesc 'Valid -> Bool
containsGrammar TypeDesc 'Valid
t
containsGrammar TypeDesc 'Valid
UnitType = Bool
False
containsGrammar (TupleType TypeDesc 'Valid
t1 TypeDesc 'Valid
t2 [TypeDesc 'Valid]
ts) = (TypeDesc 'Valid -> Bool) -> [TypeDesc 'Valid] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TypeDesc 'Valid -> Bool
containsGrammar (TypeDesc 'Valid
t1TypeDesc 'Valid -> [TypeDesc 'Valid] -> [TypeDesc 'Valid]
forall a. a -> [a] -> [a]
:TypeDesc 'Valid
t2TypeDesc 'Valid -> [TypeDesc 'Valid] -> [TypeDesc 'Valid]
forall a. a -> [a] -> [a]
:[TypeDesc 'Valid]
ts)

findAuto :: UpName -> UpName -> [XlateProd] -> Maybe XlateProd
findAuto :: UpName
-> UpName
-> [Either XlateHoleDef XlateAuto]
-> Maybe (Either XlateHoleDef XlateAuto)
findAuto UpName
sName UpName
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.nontermName UpName -> UpName -> Bool
forall a. Eq a => a -> a -> Bool
== UpName
sName Bool -> Bool -> Bool
&& XlateHoleDef
x.prodName UpName -> UpName -> Bool
forall a. Eq a => a -> a -> Bool
== UpName
pName
  f (Right XlateAuto
x) = XlateAuto
x.nontermName UpName -> UpName -> Bool
forall a. Eq a => a -> a -> Bool
== UpName
sName Bool -> Bool -> Bool
&& XlateAuto
x.prodName UpName -> UpName -> Bool
forall a. Eq a => a -> a -> Bool
== UpName
pName

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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

base26 :: [String]
base26 :: [String]
base26 = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String]
forall {t}. (Eq t, Num t) => t -> [String]
digits (Int -> [String]) -> [Int] -> [[String]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Int
0..] :: [Int])
  where
  digits :: t -> [String]
digits t
n = (:) (Char -> String -> String) -> String -> [String -> String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char
'a'..Char
'z'] [String -> String] -> [String] -> [String]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (if t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 then String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"" else t -> [String]
digits (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1))