{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

module Language.Nanopass.LangDef
  ( TypeDesc(..)
  , LangDef(..)
  , SyncatDef(..)
  , ProdDef(..)
  , SubtermDef(..)
  , Define
  , runDefine
  , defineLang
  , DefdLang(..)
  , DefdSyncatType(..)
  , DefdProd(..)
  , DefdSubterm(..)
  , reifyLang
  , LangMod(..)
  , SyncatMod(..)
  , ProdMod(..)
  , runModify
  , modifyLang
  ) where

import Control.Monad (forM,forM_,foldM,when)
import Control.Monad.State (StateT,gets,modify,evalStateT)
import Data.Bifunctor (second)
import Data.Functor ((<&>))
import Data.List (nub,(\\),stripPrefix)
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Language.Haskell.TH (Q, Dec)

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

data TypeDesc
  = RecursiveType String -- these are metavariables that start with a lowercase letter
  | VarType TH.Name
  | CtorType TH.Name [TypeDesc] -- the string here will be used to look up a type in scope at the splice site, and will start with an uppercase letter
  | ListType TypeDesc -- because otherwise, you'd have to always be saying `type List a = [a]`
  | MaybeType TypeDesc
  | NonEmptyType TypeDesc
  | TupleType TypeDesc TypeDesc [TypeDesc]
  | MapType TypeDesc TypeDesc
  deriving(TypeDesc -> TypeDesc -> Bool
(TypeDesc -> TypeDesc -> Bool)
-> (TypeDesc -> TypeDesc -> Bool) -> Eq TypeDesc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeDesc -> TypeDesc -> Bool
$c/= :: TypeDesc -> TypeDesc -> Bool
== :: TypeDesc -> TypeDesc -> Bool
$c== :: TypeDesc -> TypeDesc -> Bool
Eq,Int -> TypeDesc -> ShowS
[TypeDesc] -> ShowS
TypeDesc -> String
(Int -> TypeDesc -> ShowS)
-> (TypeDesc -> String) -> ([TypeDesc] -> ShowS) -> Show TypeDesc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeDesc] -> ShowS
$cshowList :: [TypeDesc] -> ShowS
show :: TypeDesc -> String
$cshow :: TypeDesc -> String
showsPrec :: Int -> TypeDesc -> ShowS
$cshowsPrec :: Int -> TypeDesc -> ShowS
Show)

---------------------------------
------ Language Definition ------
---------------------------------

data LangDef = LangDef
  { LangDef -> String
langNameReq :: String
  , LangDef -> [String]
langParamReqs :: [String]
  , LangDef -> [SyncatDef]
syncatReqs :: [SyncatDef]
  , LangDef -> Maybe String
originalProgram :: Maybe String
  , LangDef -> Maybe DefdLang
baseDefdLang :: Maybe DefdLang
  }
  deriving(Int -> LangDef -> ShowS
[LangDef] -> ShowS
LangDef -> String
(Int -> LangDef -> ShowS)
-> (LangDef -> String) -> ([LangDef] -> ShowS) -> Show LangDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LangDef] -> ShowS
$cshowList :: [LangDef] -> ShowS
show :: LangDef -> String
$cshow :: LangDef -> String
showsPrec :: Int -> LangDef -> ShowS
$cshowsPrec :: Int -> LangDef -> ShowS
Show)
data SyncatDef = SyncatDef
  { SyncatDef -> String
syncatNameReq :: String
  , SyncatDef -> [ProdDef]
productionReqs :: [ProdDef]
  }
  deriving(Int -> SyncatDef -> ShowS
[SyncatDef] -> ShowS
SyncatDef -> String
(Int -> SyncatDef -> ShowS)
-> (SyncatDef -> String)
-> ([SyncatDef] -> ShowS)
-> Show SyncatDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncatDef] -> ShowS
$cshowList :: [SyncatDef] -> ShowS
show :: SyncatDef -> String
$cshow :: SyncatDef -> String
showsPrec :: Int -> SyncatDef -> ShowS
$cshowsPrec :: Int -> SyncatDef -> ShowS
Show)
data ProdDef = ProdDef
  { ProdDef -> String
prodNameReq :: String
  , ProdDef -> [SubtermDef]
subtermReqs :: [SubtermDef]
  }
  deriving(Int -> ProdDef -> ShowS
[ProdDef] -> ShowS
ProdDef -> String
(Int -> ProdDef -> ShowS)
-> (ProdDef -> String) -> ([ProdDef] -> ShowS) -> Show ProdDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProdDef] -> ShowS
$cshowList :: [ProdDef] -> ShowS
show :: ProdDef -> String
$cshow :: ProdDef -> String
showsPrec :: Int -> ProdDef -> ShowS
$cshowsPrec :: Int -> ProdDef -> ShowS
Show)
data SubtermDef = SubtermDef
  { SubtermDef -> Maybe String
subtermNameReq :: Maybe String
  , SubtermDef -> TypeDesc
subtermTypeReq :: TypeDesc
  }
  deriving(Int -> SubtermDef -> ShowS
[SubtermDef] -> ShowS
SubtermDef -> String
(Int -> SubtermDef -> ShowS)
-> (SubtermDef -> String)
-> ([SubtermDef] -> ShowS)
-> Show SubtermDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubtermDef] -> ShowS
$cshowList :: [SubtermDef] -> ShowS
show :: SubtermDef -> String
$cshow :: SubtermDef -> String
showsPrec :: Int -> SubtermDef -> ShowS
$cshowsPrec :: Int -> SubtermDef -> ShowS
Show)

type Define a = StateT DefState Q a
data DefState = DefState
  { DefState -> [Name]
langTyvars :: [TH.Name]
  , DefState -> Map String Name
syncatNames :: Map String TH.Name
  }

runDefine :: Define a -> Q a
runDefine :: forall a. Define a -> Q a
runDefine = (Define a -> DefState -> Q a) -> DefState -> Define a -> Q a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Define a -> DefState -> Q a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT DefState
st0
  where
  st0 :: DefState
st0 = DefState
    { langTyvars :: [Name]
langTyvars = String -> [Name]
forall a. String -> a
errorWithoutStackTrace String
"internal nanopass error: uninitialized langTyVars"
    , syncatNames :: Map String Name
syncatNames = Map String Name
forall k a. Map k a
Map.empty
    }

defineLang :: LangDef -> Define [Dec]
defineLang :: LangDef -> Define [Dec]
defineLang LangDef
l = do
  -- initialize language type variables
  let duplicateParams :: [String]
duplicateParams = LangDef
l.langParamReqs [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub LangDef
l.langParamReqs
  if Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
duplicateParams)
    then String -> StateT DefState Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT DefState Q ()) -> String -> StateT DefState Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"in a nanopass language definition: "
      , String
"duplicate language parameter names "
      , [String] -> String
forall a. Show a => a -> String
show ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
duplicateParams)
      ]
    else (DefState -> DefState) -> StateT DefState Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DefState -> DefState) -> StateT DefState Q ())
-> (DefState -> DefState) -> StateT DefState Q ()
forall a b. (a -> b) -> a -> b
$ \DefState
st -> DefState
st{ langTyvars :: [Name]
langTyvars = String -> Name
TH.mkName (String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LangDef
l.langParamReqs }
  -- initialize syncatNames
  [String]
-> (String -> StateT DefState Q ()) -> StateT DefState Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SyncatDef -> String
syncatNameReq (SyncatDef -> String) -> [SyncatDef] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LangDef
l.syncatReqs) ((String -> StateT DefState Q ()) -> StateT DefState Q ())
-> (String -> StateT DefState Q ()) -> StateT DefState Q ()
forall a b. (a -> b) -> a -> b
$ \String
syncatReq -> do
    Map String Name
knownNames <- (DefState -> Map String Name)
-> StateT DefState Q (Map String Name)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DefState -> Map String Name
syncatNames
    case String -> Map String Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
syncatReq Map String Name
knownNames of
      Maybe Name
Nothing -> (DefState -> DefState) -> StateT DefState Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DefState -> DefState) -> StateT DefState Q ())
-> (DefState -> DefState) -> StateT DefState Q ()
forall a b. (a -> b) -> a -> b
$ \DefState
st ->
        DefState
st{syncatNames :: Map String Name
syncatNames = String -> Name -> Map String Name -> Map String Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
syncatReq (String -> Name
TH.mkName String
syncatReq) Map String Name
knownNames}
      Just Name
_ -> String -> StateT DefState Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT DefState Q ()) -> String -> StateT DefState Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"in a nanopass language definition: "
                              , String
"duplicate syntactic category (terminal/nonterminal) name "
                              , String
syncatReq
                              ]
  -- define a type with one nullary ctor for every grammatical type
  Dec
langInfo <- LangDef -> Define Dec
defineLanginfo LangDef
l
  -- define every nonterminal type
  [TyVarBndr ()]
params <- (DefState -> [Name]) -> StateT DefState Q [Name]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DefState -> [Name]
langTyvars StateT DefState Q [Name]
-> ([Name] -> [TyVarBndr ()]) -> StateT DefState Q [TyVarBndr ()]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[Name]
tvs -> [Name]
tvs [Name] -> (Name -> TyVarBndr ()) -> [TyVarBndr ()]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Name
tv -> Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV Name
tv ()
  [Dec]
syncatTypeDecs <- [SyncatDef] -> (SyncatDef -> Define Dec) -> Define [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM LangDef
l.syncatReqs ((SyncatDef -> Define Dec) -> Define [Dec])
-> (SyncatDef -> Define Dec) -> Define [Dec]
forall a b. (a -> b) -> a -> b
$ \SyncatDef
syn -> do
    let syncatName :: Name
syncatName = String -> Name
TH.mkName SyncatDef
syn.syncatNameReq
    Q () -> StateT DefState Q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift (Q () -> StateT DefState Q ()) -> Q () -> StateT DefState Q ()
forall a b. (a -> b) -> a -> b
$ 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
syncatName) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
      String
"This type is a syntactic category of the t'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ LangDef
l.langNameReq String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' language."
    [Con]
prodCtors <- ProdDef -> Define Con
defineProduction (ProdDef -> Define Con) -> [ProdDef] -> StateT DefState Q [Con]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` SyncatDef
syn.productionReqs
    Dec -> Define Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Define Dec) -> Dec -> Define Dec
forall a b. (a -> b) -> a -> b
$ Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD [] Name
syncatName [TyVarBndr ()]
params Maybe Kind
forall a. Maybe a
Nothing
            [Con]
prodCtors
            []
  [Dec] -> Define [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Define [Dec]) -> [Dec] -> Define [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
langInfo Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
syncatTypeDecs

defineLanginfo :: LangDef -> Define Dec
defineLanginfo :: LangDef -> Define Dec
defineLanginfo LangDef
l = do
  [(String, Name)]
syncatNames <- (DefState -> [(String, Name)])
-> StateT DefState Q [(String, Name)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((DefState -> [(String, Name)])
 -> StateT DefState Q [(String, Name)])
-> (DefState -> [(String, Name)])
-> StateT DefState Q [(String, Name)]
forall a b. (a -> b) -> a -> b
$ Map String Name -> [(String, Name)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map String Name -> [(String, Name)])
-> (DefState -> Map String Name) -> DefState -> [(String, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefState -> Map String Name
syncatNames
  [Con]
ctors <- [(String, Name)]
-> ((String, Name) -> Define Con) -> StateT DefState Q [Con]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, Name)]
syncatNames (((String, Name) -> Define Con) -> StateT DefState Q [Con])
-> ((String, Name) -> Define Con) -> StateT DefState Q [Con]
forall a b. (a -> b) -> a -> b
$ \(String
syncatName, Name
_) -> do
    let ctorName :: Name
ctorName = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ LangDef
l.langNameReq String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
syncatName
    Q () -> StateT DefState Q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift (Q () -> StateT DefState Q ()) -> Q () -> StateT DefState Q ()
forall a b. (a -> b) -> a -> b
$ 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
ctorName) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
      String
"Serves as a reference to the syntactic category of t'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
syncatName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'s."
    Con -> Define Con
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con -> Define Con) -> Con -> Define Con
forall a b. (a -> b) -> a -> b
$ Name -> [BangType] -> Con
TH.NormalC Name
ctorName []
  let thName :: Name
thName = String -> Name
TH.mkName LangDef
l.langNameReq
  Q () -> StateT DefState Q ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift (Q () -> StateT DefState Q ()) -> Q () -> StateT DefState Q ()
forall a b. (a -> b) -> a -> b
$ 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
thName) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [String] -> String
unlines
      [ String
"This type is generated by nanopass."
      , String
"It serves as a reference to the types of syntactic categories in the language."
      , String
"Nanopass itself uses types like these to read back in a full language that was defined in a separate splice/quasiquote."
      ]
    , case (LangDef
l.baseDefdLang, LangDef
l.originalProgram) of
      (Just DefdLang
l0, Just String
origProg) -> [String] -> String
unlines
        [ String
""
        , String
"This language was generated based on the langauge t'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show DefdLang
l0.defdLangName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
        , String
"using the following 'Language.Nanopass.deflang' program:"
        , String
""
        , [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"> " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
origProg
        ]
      (Just DefdLang
l0, Maybe String
Nothing) -> [String] -> String
unlines
        [ String
""
        , String
"This language was generated based on the langauge t'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show DefdLang
l0.defdLangName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
        ]
      (Maybe DefdLang
Nothing, Just String
origProg) -> [String] -> String
unlines
        [ String
""
        , String
"This language was generated from the following 'Language.Nanopass.deflang' program:"
        , String
""
        , [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"> " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
origProg
        ]
      (Maybe DefdLang
Nothing, Maybe String
Nothing) -> String
""
    ]
  -- I'm not sure I need these singe this type is just a glorified set of pointers, but here they are for reference
  -- dShow = TH.DerivClause Nothing [TH.ConT ''Show]
  -- dRead = TH.DerivClause Nothing [TH.ConT ''Read]
  Dec -> Define Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Define Dec) -> Dec -> Define Dec
forall a b. (a -> b) -> a -> b
$ Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD [] Name
thName [] Maybe Kind
forall a. Maybe a
Nothing [Con]
ctors []

defineProduction :: ProdDef -> Define TH.Con
defineProduction :: ProdDef -> Define Con
defineProduction ProdDef
production = do
  let members :: [(String, TypeDesc)]
members = ProdDef
production.subtermReqs [SubtermDef]
-> (SubtermDef -> (String, TypeDesc)) -> [(String, TypeDesc)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        SubtermDef (Just String
explicitName) TypeDesc
v -> (String
explicitName, TypeDesc
v)
        SubtermDef Maybe String
Nothing TypeDesc
v -> (String
"un" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProdDef
production.prodNameReq, TypeDesc
v)
  let duplicateNames :: [String]
duplicateNames = ((String, TypeDesc) -> String
forall a b. (a, b) -> a
fst ((String, TypeDesc) -> String) -> [(String, TypeDesc)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, TypeDesc)]
members) [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ((String, TypeDesc) -> String
forall a b. (a, b) -> a
fst ((String, TypeDesc) -> String) -> [(String, TypeDesc)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, TypeDesc)]
members)
  [VarBangType]
fields <- case [String]
duplicateNames of
    [] -> ((String, TypeDesc) -> StateT DefState Q VarBangType)
-> [(String, TypeDesc)] -> StateT DefState Q [VarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, TypeDesc) -> StateT DefState Q VarBangType
defineSubterm [(String, TypeDesc)]
members
    [String]
_ -> String -> StateT DefState Q [VarBangType]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT DefState Q [VarBangType])
-> String -> StateT DefState Q [VarBangType]
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"in a nanopass language definition: "
                       , String
"the following subterms were defined more than once in a production"
                       , [String] -> String
forall a. Show a => a -> String
show ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
duplicateNames)
                       ]
  Con -> Define Con
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Con -> Define Con) -> Con -> Define Con
forall a b. (a -> b) -> a -> b
$ Name -> [VarBangType] -> Con
TH.RecC (String -> Name
TH.mkName ProdDef
production.prodNameReq) [VarBangType]
fields

defineSubterm :: (String, TypeDesc) -> Define TH.VarBangType
defineSubterm :: (String, TypeDesc) -> StateT DefState Q VarBangType
defineSubterm (String
langName, TypeDesc
typeDesc) = do
  Kind
ty <- TypeDesc -> Define Kind
subtermType TypeDesc
typeDesc
  VarBangType -> StateT DefState Q VarBangType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Name
TH.mkName String
langName, Bang
noBang, Kind
ty)

subtermType :: TypeDesc -> Define TH.Type
subtermType :: TypeDesc -> Define Kind
subtermType (RecursiveType String
lName) =
  (DefState -> Maybe Name) -> StateT DefState Q (Maybe Name)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (String -> Map String Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
lName (Map String Name -> Maybe Name)
-> (DefState -> Map String Name) -> DefState -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefState -> Map String Name
syncatNames) StateT DefState Q (Maybe Name)
-> (Maybe Name -> Define Kind) -> Define Kind
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Name
thName -> do
      let grammarCtor :: Kind
grammarCtor = Name -> Kind
TH.ConT Name
thName
      Cxt
params <- (DefState -> Cxt) -> StateT DefState Q Cxt
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((DefState -> Cxt) -> StateT DefState Q Cxt)
-> (DefState -> Cxt) -> StateT DefState Q Cxt
forall a b. (a -> b) -> a -> b
$ (Name -> Kind) -> [Name] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Kind
TH.VarT ([Name] -> Cxt) -> (DefState -> [Name]) -> DefState -> Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefState -> [Name]
langTyvars
      Kind -> Define Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Define Kind) -> Kind -> Define Kind
forall a b. (a -> b) -> a -> b
$ (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
TH.AppT Kind
grammarCtor Cxt
params
      -- pure $ TH.AppT grammarCtor params
    Maybe Name
Nothing -> String -> Define Kind
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Define Kind) -> String -> Define Kind
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"in a nanopass language definition: unknown metavariable ", String
lName]
subtermType (VarType Name
vName) =
  (DefState -> Bool) -> StateT DefState Q Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Name
vName Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([Name] -> Bool) -> (DefState -> [Name]) -> DefState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefState -> [Name]
langTyvars) StateT DefState Q Bool -> (Bool -> Define Kind) -> Define Kind
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> do
      Kind -> Define Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Define Kind) -> Kind -> Define Kind
forall a b. (a -> b) -> a -> b
$ Name -> Kind
TH.VarT Name
vName
    Bool
False -> String -> Define Kind
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Define Kind) -> String -> Define Kind
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"in a nanopass language definition: unknown langauge parameter ", Name -> String
forall a. Show a => a -> String
show Name
vName]
subtermType (CtorType Name
thName [TypeDesc]
argDescs) = do
  Cxt
args <- TypeDesc -> Define Kind
subtermType (TypeDesc -> Define Kind) -> [TypeDesc] -> StateT DefState Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [TypeDesc]
argDescs
  Kind -> Define Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Define Kind) -> Kind -> Define Kind
forall a b. (a -> b) -> a -> b
$ (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
TH.AppT (Name -> Kind
TH.ConT Name
thName) Cxt
args
subtermType (ListType TypeDesc
argDesc) = do
  Kind
arg <- TypeDesc -> Define Kind
subtermType TypeDesc
argDesc
  Kind -> Define Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Define Kind) -> Kind -> Define Kind
forall a b. (a -> b) -> a -> b
$ Kind -> Kind -> Kind
TH.AppT Kind
TH.ListT Kind
arg
subtermType (NonEmptyType TypeDesc
argDesc) = do
  Kind
neType <- Q Kind -> Define Kind
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift [t|NonEmpty|]
  Kind
arg <- TypeDesc -> Define Kind
subtermType TypeDesc
argDesc
  Kind -> Define Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Define Kind) -> Kind -> Define Kind
forall a b. (a -> b) -> a -> b
$ Kind -> Kind -> Kind
TH.AppT Kind
neType Kind
arg
subtermType (MaybeType TypeDesc
argDesc) = do
  Kind
maybeType <- Q Kind -> Define Kind
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift [t|Maybe|]
  Kind
arg <- TypeDesc -> Define Kind
subtermType TypeDesc
argDesc
  Kind -> Define Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Define Kind) -> Kind -> Define Kind
forall a b. (a -> b) -> a -> b
$ Kind -> Kind -> Kind
TH.AppT Kind
maybeType Kind
arg
subtermType (TupleType TypeDesc
t1 TypeDesc
t2 [TypeDesc]
ts) = do
  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 :: Kind
thTup = Int -> Kind
TH.TupleT Int
tupLen
  Cxt
tys <- TypeDesc -> Define Kind
subtermType (TypeDesc -> Define Kind) -> [TypeDesc] -> StateT DefState Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` (TypeDesc
t1TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:TypeDesc
t2TypeDesc -> [TypeDesc] -> [TypeDesc]
forall a. a -> [a] -> [a]
:[TypeDesc]
ts)
  Kind -> Define Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Define Kind) -> Kind -> Define Kind
forall a b. (a -> b) -> a -> b
$ (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
TH.AppT Kind
thTup Cxt
tys
subtermType (MapType TypeDesc
kDesc TypeDesc
vDesc) = do
  Kind
m <- Q Kind -> Define Kind
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift [t|Map|]
  Kind
k <- TypeDesc -> Define Kind
subtermType TypeDesc
kDesc
  Kind
v <- TypeDesc -> Define Kind
subtermType TypeDesc
vDesc
  Kind -> Define Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Define Kind) -> Kind -> Define Kind
forall a b. (a -> b) -> a -> b
$ Kind -> Kind -> Kind
TH.AppT (Kind -> Kind -> Kind
TH.AppT Kind
m Kind
k) Kind
v

----------------------------------
------ Language Reification ------
----------------------------------

data DefdLang = DefdLang
  { DefdLang -> String
langQualPrefix :: String -- module name (including the dot before the basename) as requested in LangMod
  , DefdLang -> Name
defdLangName :: TH.Name
  , DefdLang -> [Name]
defdLangParams :: [TH.Name]
  , DefdLang -> Map String DefdSyncatType
defdSyncats :: Map String DefdSyncatType
  }
  deriving(Int -> DefdLang -> ShowS
[DefdLang] -> ShowS
DefdLang -> String
(Int -> DefdLang -> ShowS)
-> (DefdLang -> String) -> ([DefdLang] -> ShowS) -> Show DefdLang
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefdLang] -> ShowS
$cshowList :: [DefdLang] -> ShowS
show :: DefdLang -> String
$cshow :: DefdLang -> String
showsPrec :: Int -> DefdLang -> ShowS
$cshowsPrec :: Int -> DefdLang -> ShowS
Show)
data DefdSyncatType = DefdSyncatType
  { DefdSyncatType -> Name
defdSyncatName :: TH.Name
  , DefdSyncatType -> Map String DefdProd
defdProds :: Map String DefdProd
  }
  deriving(Int -> DefdSyncatType -> ShowS
[DefdSyncatType] -> ShowS
DefdSyncatType -> String
(Int -> DefdSyncatType -> ShowS)
-> (DefdSyncatType -> String)
-> ([DefdSyncatType] -> ShowS)
-> Show DefdSyncatType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefdSyncatType] -> ShowS
$cshowList :: [DefdSyncatType] -> ShowS
show :: DefdSyncatType -> String
$cshow :: DefdSyncatType -> String
showsPrec :: Int -> DefdSyncatType -> ShowS
$cshowsPrec :: Int -> DefdSyncatType -> ShowS
Show)
data DefdProd = DefdProd
  { DefdProd -> Name
defdProdName :: TH.Name
  , DefdProd -> [DefdSubterm]
defdSubterms :: [DefdSubterm]
  }
  deriving(Int -> DefdProd -> ShowS
[DefdProd] -> ShowS
DefdProd -> String
(Int -> DefdProd -> ShowS)
-> (DefdProd -> String) -> ([DefdProd] -> ShowS) -> Show DefdProd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefdProd] -> ShowS
$cshowList :: [DefdProd] -> ShowS
show :: DefdProd -> String
$cshow :: DefdProd -> String
showsPrec :: Int -> DefdProd -> ShowS
$cshowsPrec :: Int -> DefdProd -> ShowS
Show)
data DefdSubterm = DefdSubterm
  { DefdSubterm -> Name
defdSubtermName :: TH.Name
  , DefdSubterm -> TypeDesc
defdSubtermType :: TypeDesc
  }
  deriving(Int -> DefdSubterm -> ShowS
[DefdSubterm] -> ShowS
DefdSubterm -> String
(Int -> DefdSubterm -> ShowS)
-> (DefdSubterm -> String)
-> ([DefdSubterm] -> ShowS)
-> Show DefdSubterm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefdSubterm] -> ShowS
$cshowList :: [DefdSubterm] -> ShowS
show :: DefdSubterm -> String
$cshow :: DefdSubterm -> String
showsPrec :: Int -> DefdSubterm -> ShowS
$cshowsPrec :: Int -> DefdSubterm -> ShowS
Show)

-- given a string, we need to find the language info with that name in scope,
-- then decode each of the info's constructors into the names of grammar types,
-- then decode each grammar type
reifyLang :: String -> Q DefdLang
reifyLang :: String -> Q DefdLang
reifyLang String
langName = do
  (Name
defdLangName, [Con]
syncatPtrs) <- Q (Name, [Con])
findLangInfo
  -- determine the language's grammar types
  [(Name, [Name], [Con])]
thSyncats <- Con -> Q (Name, [Name], [Con])
findRecursiveType (Con -> Q (Name, [Name], [Con]))
-> [Con] -> Q [(Name, [Name], [Con])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Con]
syncatPtrs
  let sNames :: [Name]
sNames = [(Name, [Name], [Con])]
thSyncats [(Name, [Name], [Con])]
-> ((Name, [Name], [Con]) -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
qualSName, [Name]
_, [Con]
_) -> Name
qualSName
  [DefdSyncatType]
syncatTypeList <- [(Name, [Name], [Con])]
-> ((Name, [Name], [Con]) -> Q DefdSyncatType)
-> Q [DefdSyncatType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, [Name], [Con])]
thSyncats (((Name, [Name], [Con]) -> Q DefdSyncatType) -> Q [DefdSyncatType])
-> ((Name, [Name], [Con]) -> Q DefdSyncatType)
-> Q [DefdSyncatType]
forall a b. (a -> b) -> a -> b
$ \(Name
qualSyncatName, [Name]
paramNames, [Con]
thCtors) -> do
    [DefdProd]
ctorList <- [Name] -> [Name] -> Con -> Q DefdProd
decodeCtor [Name]
sNames [Name]
paramNames (Con -> Q DefdProd) -> [Con] -> Q [DefdProd]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Con]
thCtors
    let productions :: [(String, DefdProd)]
productions = [DefdProd]
ctorList [DefdProd]
-> (DefdProd -> (String, DefdProd)) -> [(String, DefdProd)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DefdProd
ctor -> ((Name -> String
TH.nameBase (Name -> String) -> (DefdProd -> Name) -> DefdProd -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefdProd -> Name
defdProdName) DefdProd
ctor, DefdProd
ctor)
        prodNames :: [String]
prodNames = (String, DefdProd) -> String
forall a b. (a, b) -> a
fst ((String, DefdProd) -> String) -> [(String, DefdProd)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, DefdProd)]
productions
        duplicatePNames :: [String]
duplicatePNames = [String]
prodNames [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
prodNames
    case [String]
duplicatePNames of
      [] -> DefdSyncatType -> Q DefdSyncatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure DefdSyncatType
        { defdSyncatName :: Name
defdSyncatName = Name
qualSyncatName
        , defdProds :: Map String DefdProd
defdProds = [(String, DefdProd)] -> Map String DefdProd
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, DefdProd)]
productions
        }
      [String]
_ -> String -> Q DefdSyncatType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q DefdSyncatType) -> String -> Q DefdSyncatType
forall a b. (a -> b) -> a -> b
$ String
"corrupt language has duplicate production names: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
duplicatePNames)
  -- disallowing duplicates here allows `decodeType.recurse` to produce `RecursiveType`s easily
  let syncatTypes :: [(String, DefdSyncatType)]
syncatTypes = [DefdSyncatType]
syncatTypeList [DefdSyncatType]
-> (DefdSyncatType -> (String, DefdSyncatType))
-> [(String, DefdSyncatType)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DefdSyncatType
t -> ((Name -> String
TH.nameBase (Name -> String)
-> (DefdSyncatType -> Name) -> DefdSyncatType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefdSyncatType -> Name
defdSyncatName) DefdSyncatType
t, DefdSyncatType
t)
      syncatNames :: [String]
syncatNames = (String, DefdSyncatType) -> String
forall a b. (a, b) -> a
fst ((String, DefdSyncatType) -> String)
-> [(String, DefdSyncatType)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, DefdSyncatType)]
syncatTypes
      duplicateSNames :: [String]
duplicateSNames = [String]
syncatNames [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
\\ [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
syncatNames
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
duplicateSNames) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
    String
"corrupt language has duplicate syntactic category names: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
duplicateSNames)
  -- determine the language's type parameters
  [Name]
defdLangParams <-
    let f :: Maybe (f Name) -> (a, f Name, c) -> f (Maybe (f Name))
f Maybe (f Name)
Nothing (a
_, f Name
tvs, c
_) = Maybe (f Name) -> f (Maybe (f Name))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f Name -> Maybe (f Name)
forall a. a -> Maybe a
Just (f Name -> Maybe (f Name)) -> f Name -> Maybe (f Name)
forall a b. (a -> b) -> a -> b
$ Name -> Name
fixup (Name -> Name) -> f Name -> f Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Name
tvs)
        f (Just f Name
tvs) (a
_, f Name
tvs', c
_)
          | f Name
tvs f Name -> f Name -> Bool
forall a. Eq a => a -> a -> Bool
== (Name -> Name
fixup (Name -> Name) -> f Name -> f Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Name
tvs') = Maybe (f Name) -> f (Maybe (f Name))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f Name -> Maybe (f Name)
forall a. a -> Maybe a
Just f Name
tvs)
          | Bool
otherwise = String -> f (Maybe (f Name))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f (Maybe (f Name))) -> String -> f (Maybe (f Name))
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"corrupt language has differing paramaters between syntactic categories. expected:\n"
            , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ f Name -> String
forall a. Show a => a -> String
show f Name
tvs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
            , String
"got:\n"
            , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ f Name -> String
forall a. Show a => a -> String
show (Name -> Name
fixup (Name -> Name) -> f Name -> f Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Name
tvs')
            ]
     in [Name] -> Maybe [Name] -> [Name]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Name] -> [Name]) -> Q (Maybe [Name]) -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe [Name] -> (Name, [Name], [Con]) -> Q (Maybe [Name]))
-> Maybe [Name] -> [(Name, [Name], [Con])] -> Q (Maybe [Name])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Maybe [Name] -> (Name, [Name], [Con]) -> Q (Maybe [Name])
forall {f :: * -> *} {f :: * -> *} {a} {c}.
(Eq (f Name), MonadFail f, Show (f Name), Functor f) =>
Maybe (f Name) -> (a, f Name, c) -> f (Maybe (f Name))
f Maybe [Name]
forall a. Maybe a
Nothing [(Name, [Name], [Con])]
thSyncats
  -- and we're done
  DefdLang -> Q DefdLang
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DefdLang -> Q DefdLang) -> DefdLang -> Q DefdLang
forall a b. (a -> b) -> a -> b
$ DefdLang
    { String
langQualPrefix :: String
langQualPrefix :: String
langQualPrefix
    , Name
defdLangName :: Name
defdLangName :: Name
defdLangName
    , [Name]
defdLangParams :: [Name]
defdLangParams :: [Name]
defdLangParams
    , defdSyncats :: Map String DefdSyncatType
defdSyncats = [(String, DefdSyncatType)] -> Map String DefdSyncatType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, DefdSyncatType)]
syncatTypes
    }
  where
  -- this is here because TH will add a bunch of garbage on the end of a type variable to ensure it doesn't capture,
  -- but in this case I _want_ it to capture, so I can check name equality across different types
  fixup :: TH.Name -> TH.Name
  fixup :: Name -> Name
fixup = String -> Name
TH.mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
loop ShowS -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show
    where
    loop :: ShowS
loop (Char
c:String
rest)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' = String
rest
      | Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = ShowS
loop String
rest
    loop String
other = String
other
  langQualPrefix :: String
langQualPrefix = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
langName
  langBase :: String
langBase = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
langName
  decodeCtor :: [TH.Name] -> [TH.Name] -> TH.Con -> Q DefdProd
  decodeCtor :: [Name] -> [Name] -> Con -> Q DefdProd
decodeCtor [Name]
sNames [Name]
paramNames (TH.RecC Name
defdProdName [VarBangType]
thFields) = do
    [DefdSubterm]
defdSubterms <- [VarBangType] -> (VarBangType -> Q DefdSubterm) -> Q [DefdSubterm]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [VarBangType]
thFields ((VarBangType -> Q DefdSubterm) -> Q [DefdSubterm])
-> (VarBangType -> Q DefdSubterm) -> Q [DefdSubterm]
forall a b. (a -> b) -> a -> b
$ \(Name
thFieldName, Bang
_, Kind
thSubtermType) -> do
      TypeDesc
typeDesc <- [Name] -> [Name] -> Kind -> Q TypeDesc
decodeType [Name]
sNames [Name]
paramNames Kind
thSubtermType
      DefdSubterm -> Q DefdSubterm
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DefdSubterm -> Q DefdSubterm) -> DefdSubterm -> Q DefdSubterm
forall a b. (a -> b) -> a -> b
$ Name -> TypeDesc -> DefdSubterm
DefdSubterm Name
thFieldName TypeDesc
typeDesc
    DefdProd -> Q DefdProd
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DefdProd -> Q DefdProd) -> DefdProd -> Q DefdProd
forall a b. (a -> b) -> a -> b
$ DefdProd{Name
defdProdName :: Name
defdProdName :: Name
defdProdName,[DefdSubterm]
defdSubterms :: [DefdSubterm]
defdSubterms :: [DefdSubterm]
defdSubterms}
  decodeCtor [Name]
_ [Name]
_ Con
otherCtor = String -> Q DefdProd
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q DefdProd) -> String -> Q DefdProd
forall a b. (a -> b) -> a -> b
$ String
"corrupt production type:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
otherCtor
  decodeType :: [TH.Name] -> [TH.Name] -> TH.Type -> Q TypeDesc
  decodeType :: [Name] -> [Name] -> Kind -> Q TypeDesc
decodeType [Name]
sNames [Name]
paramNames Kind
type0 = Kind -> Q TypeDesc
forall {m :: * -> *}. MonadFail m => Kind -> m TypeDesc
recurse Kind
type0
    where
    tvs :: Cxt
tvs = Name -> Kind
TH.VarT (Name -> Kind) -> [Name] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
paramNames
    recurse :: Kind -> m TypeDesc
recurse Kind
tuple | Just (Kind
t1:Kind
t2:Cxt
ts) <- Kind -> Maybe Cxt
fromTuple Kind
tuple = do
      TypeDesc
t1Desc <- Kind -> m TypeDesc
recurse Kind
t1
      TypeDesc
t2Desc <- Kind -> m TypeDesc
recurse Kind
t2
      [TypeDesc]
tDescs <- Kind -> m TypeDesc
recurse (Kind -> m TypeDesc) -> Cxt -> m [TypeDesc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` Cxt
ts
      TypeDesc -> m TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> m TypeDesc) -> TypeDesc -> m TypeDesc
forall a b. (a -> b) -> a -> b
$ TypeDesc -> TypeDesc -> [TypeDesc] -> TypeDesc
TupleType TypeDesc
t1Desc TypeDesc
t2Desc [TypeDesc]
tDescs
    recurse (TH.AppT (TH.AppT (TH.ConT Name
special) Kind
k) Kind
v)
      | Name
special Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Map = TypeDesc -> TypeDesc -> TypeDesc
MapType (TypeDesc -> TypeDesc -> TypeDesc)
-> m TypeDesc -> m (TypeDesc -> TypeDesc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> m TypeDesc
recurse Kind
k m (TypeDesc -> TypeDesc) -> m TypeDesc -> m TypeDesc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Kind -> m TypeDesc
recurse Kind
v
    recurse (TH.AppT (TH.ConT Name
special) Kind
a)
      | Name
special Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe = TypeDesc -> TypeDesc
MaybeType (TypeDesc -> TypeDesc) -> m TypeDesc -> m TypeDesc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> m TypeDesc
recurse Kind
a
      | Name
special Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''NonEmpty = TypeDesc -> TypeDesc
NonEmptyType (TypeDesc -> TypeDesc) -> m TypeDesc -> m TypeDesc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> m TypeDesc
recurse Kind
a
    recurse (TH.AppT Kind
TH.ListT Kind
a) = TypeDesc -> TypeDesc
ListType (TypeDesc -> TypeDesc) -> m TypeDesc -> m TypeDesc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> m TypeDesc
recurse Kind
a
    recurse Kind
appType
      | (TH.ConT Name
thName, Cxt
args) <- Kind -> (Kind, Cxt)
fromApps Kind
appType
      , Name
thName Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
sNames Bool -> Bool -> Bool
&& Cxt
args Cxt -> Cxt -> Bool
forall a. Eq a => a -> a -> Bool
== Cxt
tvs
        -- we can just use TH.nameBase here, because in reifyLang, we make sure that there are no duplicates
        -- (there shouldn't be any duplicates anyway as long as language being decoded was generated by this library)
        = TypeDesc -> m TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> m TypeDesc) -> TypeDesc -> m TypeDesc
forall a b. (a -> b) -> a -> b
$ String -> TypeDesc
RecursiveType (Name -> String
TH.nameBase Name
thName)
      | (TH.ConT Name
thName, Cxt
args) <- Kind -> (Kind, Cxt)
fromApps Kind
appType = do
        [TypeDesc]
decodedArgs <- Kind -> m TypeDesc
recurse (Kind -> m TypeDesc) -> Cxt -> m [TypeDesc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` Cxt
args
        TypeDesc -> m TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> m TypeDesc) -> TypeDesc -> m TypeDesc
forall a b. (a -> b) -> a -> b
$ Name -> [TypeDesc] -> TypeDesc
CtorType Name
thName [TypeDesc]
decodedArgs
    recurse (TH.VarT Name
a) = TypeDesc -> m TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> m TypeDesc) -> TypeDesc -> m TypeDesc
forall a b. (a -> b) -> a -> b
$ Name -> TypeDesc
VarType Name
a
    recurse Kind
otherType = String -> m TypeDesc
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m TypeDesc) -> String -> m TypeDesc
forall a b. (a -> b) -> a -> b
$ String
"corrupt subterm type:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
otherType String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n in type:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
type0
    fromTuple :: TH.Type -> Maybe [TH.Type]
    fromTuple :: Kind -> Maybe Cxt
fromTuple Kind
t0 = case Kind -> Maybe (Int, Cxt)
loop Kind
t0 of
      Just (Int
0, Cxt
ts) -> Cxt -> Maybe Cxt
forall a. a -> Maybe a
Just (Cxt -> Cxt
forall a. [a] -> [a]
reverse Cxt
ts)
      Maybe (Int, Cxt)
_ -> Maybe Cxt
forall a. Maybe a
Nothing
      where
      loop :: Kind -> Maybe (Int, Cxt)
loop (TH.TupleT Int
n) = (Int, Cxt) -> Maybe (Int, Cxt)
forall a. a -> Maybe a
Just (Int
n, [])
      loop (TH.AppT Kind
f Kind
t)
        | Just (Int
n, Cxt
ts) <- Kind -> Maybe (Int, Cxt)
loop Kind
f = (Int, Cxt) -> Maybe (Int, Cxt)
forall a. a -> Maybe a
Just (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Kind
tKind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:Cxt
ts)
      loop Kind
_ = Maybe (Int, Cxt)
forall a. Maybe a
Nothing
    fromApps :: TH.Type -> (TH.Type, [TH.Type])
    fromApps :: Kind -> (Kind, Cxt)
fromApps = (Cxt -> Cxt) -> (Kind, Cxt) -> (Kind, Cxt)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Cxt -> Cxt
forall a. [a] -> [a]
reverse ((Kind, Cxt) -> (Kind, Cxt))
-> (Kind -> (Kind, Cxt)) -> Kind -> (Kind, Cxt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> (Kind, Cxt)
loop
      where
      loop :: Kind -> (Kind, Cxt)
loop (TH.AppT Kind
inner Kind
lastArg) = (Cxt -> Cxt) -> (Kind, Cxt) -> (Kind, Cxt)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Kind
lastArgKind -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:) (Kind -> (Kind, Cxt)
loop Kind
inner)
      loop Kind
t = (Kind
t, [])
  findLangInfo :: Q (TH.Name, [TH.Con]) -- name and constructors of the info type
  findLangInfo :: Q (Name, [Con])
findLangInfo = String -> Q (Maybe Name)
TH.lookupTypeName String
langName Q (Maybe Name)
-> (Maybe Name -> Q (Name, [Con])) -> Q (Name, [Con])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Name
Nothing -> String -> Q (Name, [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Con])) -> String -> Q (Name, [Con])
forall a b. (a -> b) -> a -> b
$ String
"in a nanopass language extension: could not find base language " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
langName
    Just Name
defdLangName -> Name -> Q Info
TH.reify Name
defdLangName Q Info -> (Info -> Q (Name, [Con])) -> Q (Name, [Con])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TH.TyConI (TH.DataD [] Name
qualThLangName [] Maybe Kind
Nothing [Con]
syncatNames [DerivClause]
_) -> (Name, [Con]) -> Q (Name, [Con])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
qualThLangName, [Con]
syncatNames)
      Info
otherInfo -> String -> Q (Name, [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Con])) -> String -> Q (Name, [Con])
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"in a nanopass language extension: base name " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
langName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not identify a language: "
        , String
"  expecting language name to identify data definition, but got this type:\n"
        , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
otherInfo
        ]
  findRecursiveType :: TH.Con -> Q (TH.Name, [TH.Name], [TH.Con])
  findRecursiveType :: Con -> Q (Name, [Name], [Con])
findRecursiveType (TH.NormalC Name
thTypePtr []) = do
    let enumPrefix :: String
enumPrefix = String
langBase String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_"
    String
typePtrBase <- case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
enumPrefix (Name -> String
TH.nameBase Name
thTypePtr) of
      Just String
it -> String -> Q String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
it
      Maybe String
Nothing -> String -> Q String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q String) -> String -> Q String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"in a nanopass language extension: base name " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
langBase String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not identify a language: "
        , String
"  expecting language info enum ctors to start with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
enumPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", but got name:\n"
        , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
TH.nameBase Name
thTypePtr
        ]
    let typePtr :: Name
typePtr = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
langQualPrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
typePtrBase
    Name -> Q Info
TH.reify Name
typePtr Q Info
-> (Info -> Q (Name, [Name], [Con])) -> Q (Name, [Name], [Con])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TH.TyConI (TH.DataD [] Name
qualSyncatName [TyVarBndr ()]
thParams Maybe Kind
_ [Con]
ctors [DerivClause]
_) -> do
        let thParamNames :: [Name]
thParamNames = [TyVarBndr ()]
thParams [TyVarBndr ()] -> (TyVarBndr () -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case { TH.PlainTV Name
it ()
_ -> Name
it ; TH.KindedTV Name
it ()
_ Kind
_ -> Name
it }
        (Name, [Name], [Con]) -> Q (Name, [Name], [Con])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
qualSyncatName, [Name]
thParamNames, [Con]
ctors)
      Info
otherType -> String -> Q (Name, [Name], [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Name], [Con]))
-> String -> Q (Name, [Name], [Con])
forall a b. (a -> b) -> a -> b
$ String
"corrupt language syntactic category type:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
otherType
  findRecursiveType Con
otherCtor = String -> Q (Name, [Name], [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Name], [Con]))
-> String -> Q (Name, [Name], [Con])
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"in a nanopass language extension: base name " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
langName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not identify a language: "
    , String
"  expecting language name to identify an enum, but got this constructor:\n"
    , String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
otherCtor
    ]

--------------------------------
------ Language Extension ------
--------------------------------

data LangMod = LangMod
  { LangMod -> String
baseLangReq :: String
  , LangMod -> String
newLangReq :: String
  , LangMod -> [String]
newParamReqs :: [String]
  , LangMod -> [SyncatMod]
syncatMods :: [SyncatMod]
  , LangMod -> Maybe String
originalModProgram :: Maybe String
  }
  deriving(Int -> LangMod -> ShowS
[LangMod] -> ShowS
LangMod -> String
(Int -> LangMod -> ShowS)
-> (LangMod -> String) -> ([LangMod] -> ShowS) -> Show LangMod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LangMod] -> ShowS
$cshowList :: [LangMod] -> ShowS
show :: LangMod -> String
$cshow :: LangMod -> String
showsPrec :: Int -> LangMod -> ShowS
$cshowsPrec :: Int -> LangMod -> ShowS
Show)
data SyncatMod
  = AddSyncat SyncatDef
  | DelSyncat String
  | ModProds
    { SyncatMod -> String
syncatName :: String
    , SyncatMod -> [ProdMod]
prodMods :: [ProdMod]
    }
  deriving(Int -> SyncatMod -> ShowS
[SyncatMod] -> ShowS
SyncatMod -> String
(Int -> SyncatMod -> ShowS)
-> (SyncatMod -> String)
-> ([SyncatMod] -> ShowS)
-> Show SyncatMod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncatMod] -> ShowS
$cshowList :: [SyncatMod] -> ShowS
show :: SyncatMod -> String
$cshow :: SyncatMod -> String
showsPrec :: Int -> SyncatMod -> ShowS
$cshowsPrec :: Int -> SyncatMod -> ShowS
Show)
data ProdMod
  = AddProd ProdDef
  | DelProd String
  deriving(Int -> ProdMod -> ShowS
[ProdMod] -> ShowS
ProdMod -> String
(Int -> ProdMod -> ShowS)
-> (ProdMod -> String) -> ([ProdMod] -> ShowS) -> Show ProdMod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProdMod] -> ShowS
$cshowList :: [ProdMod] -> ShowS
show :: ProdMod -> String
$cshow :: ProdMod -> String
showsPrec :: Int -> ProdMod -> ShowS
$cshowsPrec :: Int -> ProdMod -> ShowS
Show)

runModify :: LangMod -> Q [Dec]
runModify :: LangMod -> Q [Dec]
runModify LangMod
lMod = do
  DefdLang
oldLang <- String -> Q DefdLang
reifyLang (LangMod -> String
baseLangReq LangMod
lMod)
  DefdLang -> LangMod -> Q [Dec]
modifyLang DefdLang
oldLang LangMod
lMod

modifyLang :: DefdLang -> LangMod -> Q [Dec]
modifyLang :: DefdLang -> LangMod -> Q [Dec]
modifyLang DefdLang
defd LangMod
mods = do
  DefdLang
defd' <- DefdLang -> [SyncatMod] -> Q DefdLang
restrictLang DefdLang
defd (LangMod -> [SyncatMod]
syncatMods LangMod
mods)
  -- TODO I think it's at this point that I can generate the default translation
  LangDef
lang' <- DefdLang -> LangMod -> Q LangDef
extendLang DefdLang
defd' LangMod
mods
  Define [Dec] -> Q [Dec]
forall a. Define a -> Q a
runDefine (Define [Dec] -> Q [Dec]) -> Define [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ LangDef -> Define [Dec]
defineLang LangDef
lang'

restrictLang :: DefdLang -> [SyncatMod] -> Q DefdLang
restrictLang :: DefdLang -> [SyncatMod] -> Q DefdLang
restrictLang = (DefdLang -> SyncatMod -> Q DefdLang)
-> DefdLang -> [SyncatMod] -> Q DefdLang
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM DefdLang -> SyncatMod -> Q DefdLang
doSyncat
  where
  doSyncat :: DefdLang -> SyncatMod -> Q DefdLang
  doSyncat :: DefdLang -> SyncatMod -> Q DefdLang
doSyncat DefdLang
l (AddSyncat SyncatDef
_) = DefdLang -> Q DefdLang
forall (f :: * -> *) a. Applicative f => a -> f a
pure DefdLang
l
  doSyncat DefdLang
l (DelSyncat String
sName) = case String -> Map String DefdSyncatType -> Maybe DefdSyncatType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
sName DefdLang
l.defdSyncats of
    Just DefdSyncatType
_ -> DefdLang -> Q DefdLang
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DefdLang -> Q DefdLang) -> DefdLang -> Q DefdLang
forall a b. (a -> b) -> a -> b
$ DefdLang
l{ defdSyncats :: Map String DefdSyncatType
defdSyncats = String -> Map String DefdSyncatType -> Map String DefdSyncatType
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
sName DefdLang
l.defdSyncats }
    Maybe DefdSyncatType
Nothing -> String -> Q DefdLang
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q DefdLang) -> String -> Q DefdLang
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"in nanopass language extention: "
      , String
"attempt to delete non-existent syntactic category "
      , String
sName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (DefdLang -> Name
defdLangName DefdLang
l)
      ]
  doSyncat DefdLang
l (ModProds String
sName [ProdMod]
prodMods) = case String -> Map String DefdSyncatType -> Maybe DefdSyncatType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
sName DefdLang
l.defdSyncats of
    Just DefdSyncatType
syncat -> do
      DefdSyncatType
syncat' <- (DefdSyncatType -> ProdMod -> Q DefdSyncatType)
-> DefdSyncatType -> [ProdMod] -> Q DefdSyncatType
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM DefdSyncatType -> ProdMod -> Q DefdSyncatType
doProds DefdSyncatType
syncat [ProdMod]
prodMods
      DefdLang -> Q DefdLang
forall (f :: * -> *) a. Applicative f => a -> f a
pure DefdLang
l{ defdSyncats :: Map String DefdSyncatType
defdSyncats = String
-> DefdSyncatType
-> Map String DefdSyncatType
-> Map String DefdSyncatType
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
sName DefdSyncatType
syncat' DefdLang
l.defdSyncats }
    Maybe DefdSyncatType
Nothing -> String -> Q DefdLang
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q DefdLang) -> String -> Q DefdLang
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"in nanopass language extension: "
      , String
"attempt to modify non-existent syntactic category "
      , String
sName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (DefdLang -> Name
defdLangName DefdLang
l)
      ]
    where
    doProds :: DefdSyncatType -> ProdMod -> Q DefdSyncatType
    doProds :: DefdSyncatType -> ProdMod -> Q DefdSyncatType
doProds DefdSyncatType
s (AddProd ProdDef
_) = DefdSyncatType -> Q DefdSyncatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure DefdSyncatType
s
    doProds DefdSyncatType
s (DelProd String
pName) = case String -> Map String DefdProd -> Maybe DefdProd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
pName DefdSyncatType
s.defdProds of
      Just DefdProd
_ -> DefdSyncatType -> Q DefdSyncatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DefdSyncatType -> Q DefdSyncatType)
-> DefdSyncatType -> Q DefdSyncatType
forall a b. (a -> b) -> a -> b
$ DefdSyncatType
s{ defdProds :: Map String DefdProd
defdProds = String -> Map String DefdProd -> Map String DefdProd
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
pName DefdSyncatType
s.defdProds }
      Maybe DefdProd
Nothing -> String -> Q DefdSyncatType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q DefdSyncatType) -> String -> Q DefdSyncatType
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"in nanopass language extention: "
        , String
"attempt to delete non-existent term constructor "
        , String
sName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show DefdSyncatType
s.defdSyncatName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show DefdLang
l.defdLangName
        ]

extendLang :: DefdLang -> LangMod -> Q LangDef
extendLang :: DefdLang -> LangMod -> Q LangDef
extendLang DefdLang
l LangMod
lMods = do
  [SyncatDef]
syncatReqs0 <- [SyncatMod] -> DefdSyncatType -> Q SyncatDef
doSyncat LangMod
lMods.syncatMods (DefdSyncatType -> Q SyncatDef)
-> [DefdSyncatType] -> Q [SyncatDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` Map String DefdSyncatType -> [DefdSyncatType]
forall k a. Map k a -> [a]
Map.elems DefdLang
l.defdSyncats
  let syncatReqs :: [SyncatDef]
syncatReqs = [SyncatDef]
syncatReqs0 [SyncatDef] -> [SyncatDef] -> [SyncatDef]
forall a. [a] -> [a] -> [a]
++ [SyncatMod] -> [SyncatDef]
catAddSyncat LangMod
lMods.syncatMods
  LangDef -> Q LangDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LangDef -> Q LangDef) -> LangDef -> Q LangDef
forall a b. (a -> b) -> a -> b
$ LangDef
    { langNameReq :: String
langNameReq = LangMod
lMods.newLangReq
    , langParamReqs :: [String]
langParamReqs = LangMod
lMods.newParamReqs
    , [SyncatDef]
syncatReqs :: [SyncatDef]
syncatReqs :: [SyncatDef]
syncatReqs
    , originalProgram :: Maybe String
originalProgram = LangMod
lMods.originalModProgram
    , baseDefdLang :: Maybe DefdLang
baseDefdLang = DefdLang -> Maybe DefdLang
forall a. a -> Maybe a
Just DefdLang
l
    }
  where
  doSyncat :: [SyncatMod] -> DefdSyncatType -> Q SyncatDef
  doSyncat :: [SyncatMod] -> DefdSyncatType -> Q SyncatDef
doSyncat [SyncatMod]
gMods DefdSyncatType{Name
defdSyncatName :: Name
defdSyncatName :: DefdSyncatType -> Name
defdSyncatName,Map String DefdProd
defdProds :: Map String DefdProd
defdProds :: DefdSyncatType -> Map String DefdProd
defdProds} = do
    let productionReqs0 :: [ProdDef]
productionReqs0 = DefdProd -> ProdDef
doProd (DefdProd -> ProdDef) -> [DefdProd] -> [ProdDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map String DefdProd -> [DefdProd]
forall k a. Map k a -> [a]
Map.elems Map String DefdProd
defdProds
    let productionReqs :: [ProdDef]
productionReqs = [ProdDef]
productionReqs0 [ProdDef] -> [ProdDef] -> [ProdDef]
forall a. [a] -> [a] -> [a]
++ Name -> [SyncatMod] -> [ProdDef]
catAddProd Name
defdSyncatName [SyncatMod]
gMods
    SyncatDef -> Q SyncatDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure SyncatDef{syncatNameReq :: String
syncatNameReq = Name -> String
TH.nameBase Name
defdSyncatName, [ProdDef]
productionReqs :: [ProdDef]
productionReqs :: [ProdDef]
productionReqs}
  doProd :: DefdProd -> ProdDef
  doProd :: DefdProd -> ProdDef
doProd DefdProd{Name
defdProdName :: Name
defdProdName :: DefdProd -> Name
defdProdName, [DefdSubterm]
defdSubterms :: [DefdSubterm]
defdSubterms :: DefdProd -> [DefdSubterm]
defdSubterms} =
    String -> [SubtermDef] -> ProdDef
ProdDef (Name -> String
TH.nameBase Name
defdProdName) (DefdSubterm -> SubtermDef
doSubterm (DefdSubterm -> SubtermDef) -> [DefdSubterm] -> [SubtermDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DefdSubterm]
defdSubterms)
  doSubterm :: DefdSubterm -> SubtermDef
  doSubterm :: DefdSubterm -> SubtermDef
doSubterm DefdSubterm{Name
defdSubtermName :: Name
defdSubtermName :: DefdSubterm -> Name
defdSubtermName, TypeDesc
defdSubtermType :: TypeDesc
defdSubtermType :: DefdSubterm -> TypeDesc
defdSubtermType} =
    Maybe String -> TypeDesc -> SubtermDef
SubtermDef (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Name -> String
TH.nameBase Name
defdSubtermName) TypeDesc
defdSubtermType
  catAddSyncat :: [SyncatMod] -> [SyncatDef]
catAddSyncat (AddSyncat SyncatDef
s : [SyncatMod]
moreSMods) = SyncatDef
s SyncatDef -> [SyncatDef] -> [SyncatDef]
forall a. a -> [a] -> [a]
: [SyncatMod] -> [SyncatDef]
catAddSyncat [SyncatMod]
moreSMods
  catAddSyncat (SyncatMod
_ : [SyncatMod]
moreSMods) = [SyncatMod] -> [SyncatDef]
catAddSyncat [SyncatMod]
moreSMods
  catAddSyncat [] = []
  catAddProd :: Name -> [SyncatMod] -> [ProdDef]
catAddProd Name
thName (ModProds String
toName [ProdMod]
prodMods : [SyncatMod]
moreSMods)
    | String
toName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
TH.nameBase Name
thName = [ProdMod] -> [ProdDef]
go [ProdMod]
prodMods [ProdDef] -> [ProdDef] -> [ProdDef]
forall a. [a] -> [a] -> [a]
++ Name -> [SyncatMod] -> [ProdDef]
catAddProd Name
thName [SyncatMod]
moreSMods
    where
    go :: [ProdMod] -> [ProdDef]
go (AddProd ProdDef
p : [ProdMod]
morePMods) = ProdDef
p ProdDef -> [ProdDef] -> [ProdDef]
forall a. a -> [a] -> [a]
: [ProdMod] -> [ProdDef]
go [ProdMod]
morePMods
    go (ProdMod
_ : [ProdMod]
morePMods) = [ProdMod] -> [ProdDef]
go [ProdMod]
morePMods
    go [] = []
  catAddProd Name
thName (SyncatMod
_ : [SyncatMod]
morePMods) = Name -> [SyncatMod] -> [ProdDef]
catAddProd Name
thName [SyncatMod]
morePMods
  catAddProd Name
_ [] = []


------------------------
------ TH Helpers ------
------------------------

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