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

module Language.Nanopass.LangDef
  ( Define
  , runDefine
  , defineLang
  , reifyLang
  , runModify
  ) where

import Nanopass.Internal.Representation

import Control.Monad (forM,forM_,foldM,when)
import Nanopass.Internal.Extend (extendLang)
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 Data.Text.Lazy as LT
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Text.Pretty.Simple as PP

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

type Define a = StateT DefState Q a

data DefState = DefState
  { DefState -> [Name]
langTyvars :: [TH.Name]
  , DefState -> Map UpName Name
nontermNames :: Map UpName 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
    { $sel:langTyvars:DefState :: [Name]
langTyvars = String -> [Name]
forall a. String -> a
errorWithoutStackTrace String
"internal nanopass error: uninitialized langTyVars"
    , $sel:nontermNames:DefState :: Map UpName Name
nontermNames = Map UpName Name
forall k a. Map k a
Map.empty
    }

defineLang :: Language 'Valid UpName -> Define [Dec]
defineLang :: Language 'Valid UpName -> Define [Dec]
defineLang Language 'Valid UpName
l = do
  -- initialize language type variables
  let duplicateParams :: [Name 'Valid LowName]
duplicateParams = Language 'Valid UpName
l.langInfo.langParams [Name 'Valid LowName]
-> [Name 'Valid LowName] -> [Name 'Valid LowName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Name 'Valid LowName] -> [Name 'Valid LowName]
forall a. Eq a => [a] -> [a]
nub Language 'Valid UpName
l.langInfo.langParams
  if Bool -> Bool
not ([Name 'Valid LowName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name 'Valid LowName]
duplicateParams)
    then String -> StateT DefState Q ()
forall a. String -> StateT DefState Q a
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 "
      , [Name 'Valid LowName] -> String
forall a. Show a => a -> String
show ([Name 'Valid LowName] -> [Name 'Valid LowName]
forall a. Eq a => [a] -> [a]
nub [Name 'Valid LowName]
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 = (.th) <$> l.langInfo.langParams }
  -- initialize nontermNames
  Map UpName (Nonterm 'Valid)
-> (Nonterm 'Valid -> StateT DefState Q ()) -> StateT DefState Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Language 'Valid UpName
l.langInfo.nonterms ((Nonterm 'Valid -> StateT DefState Q ()) -> StateT DefState Q ())
-> (Nonterm 'Valid -> StateT DefState Q ()) -> StateT DefState Q ()
forall a b. (a -> b) -> a -> b
$ \Nonterm 'Valid
nonterm -> do
    Map UpName Name
knownNames <- (DefState -> Map UpName Name)
-> StateT DefState Q (Map UpName Name)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DefState -> Map UpName Name
nontermNames
    case UpName -> Map UpName Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Nonterm 'Valid
nonterm.nontermName.name Map UpName 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{nontermNames = Map.insert nonterm.nontermName.name nonterm.nontermName.th knownNames}
      Just Name
_ -> String -> StateT DefState Q ()
forall a. String -> StateT DefState Q a
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 non-terminal (terminal/nonterminal) name "
                              , UpName -> String
fromUpName Nonterm 'Valid
nonterm.nontermName.name
                              ]
  -- define a type with one nullary ctor for every grammatical type
  Dec
langInfo <- Language 'Valid UpName -> Define Dec
defineLangHeader Language 'Valid UpName
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]
nontermTypeDecs <- [Nonterm 'Valid] -> (Nonterm 'Valid -> Define Dec) -> Define [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map UpName (Nonterm 'Valid) -> [Nonterm 'Valid]
forall k a. Map k a -> [a]
Map.elems Language 'Valid UpName
l.langInfo.nonterms) ((Nonterm 'Valid -> Define Dec) -> Define [Dec])
-> (Nonterm 'Valid -> Define Dec) -> Define [Dec]
forall a b. (a -> b) -> a -> b
$ \Nonterm 'Valid
nonterm -> do
    Q () -> StateT DefState Q ()
forall (m :: * -> *) a. Monad m => m a -> StateT DefState m a
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 Nonterm 'Valid
nonterm.nontermName.th) (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
      String
"This type is a non-terminal of the t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName Language 'Valid UpName
l.langName.name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' language."
    [Con]
prodCtors <- Production 'Valid -> Define Con
defineProduction (Production 'Valid -> Define Con)
-> [Production 'Valid] -> StateT DefState Q [Con]
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` Map UpName (Production 'Valid) -> [Production 'Valid]
forall k a. Map k a -> [a]
Map.elems Nonterm 'Valid
nonterm.productions
    Dec -> Define Dec
forall a. a -> StateT DefState Q a
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 [] Nonterm 'Valid
nonterm.nontermName.th [TyVarBndr ()]
params Maybe Kind
forall a. Maybe a
Nothing
            [Con]
prodCtors
            []
  [Dec] -> Define [Dec]
forall a. a -> StateT DefState Q a
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]
nontermTypeDecs

defineLangHeader :: Language 'Valid UpName -> Define Dec
defineLangHeader :: Language 'Valid UpName -> Define Dec
defineLangHeader Language 'Valid UpName
l = do
  [(UpName, Name)]
nontermNames <- (DefState -> [(UpName, Name)])
-> StateT DefState Q [(UpName, Name)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((DefState -> [(UpName, Name)])
 -> StateT DefState Q [(UpName, Name)])
-> (DefState -> [(UpName, Name)])
-> StateT DefState Q [(UpName, Name)]
forall a b. (a -> b) -> a -> b
$ Map UpName Name -> [(UpName, Name)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map UpName Name -> [(UpName, Name)])
-> (DefState -> Map UpName Name) -> DefState -> [(UpName, Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefState -> Map UpName Name
nontermNames
  [Con]
ctors <- [(UpName, Name)]
-> ((UpName, 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 [(UpName, Name)]
nontermNames (((UpName, Name) -> Define Con) -> StateT DefState Q [Con])
-> ((UpName, Name) -> Define Con) -> StateT DefState Q [Con]
forall a b. (a -> b) -> a -> b
$ \(UpName
nontermName, Name
_) -> do
    let ctorName :: Name
ctorName = String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpName -> String
fromUpName Language 'Valid UpName
l.langName.name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName UpName
nontermName
    Q () -> StateT DefState Q ()
forall (m :: * -> *) a. Monad m => m a -> StateT DefState m a
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 non-terminal of t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpName -> String
fromUpName UpName
nontermName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'s."
    Con -> Define Con
forall a. a -> StateT DefState Q a
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 = Language 'Valid UpName
l.langName.th
  Q () -> StateT DefState Q ()
forall (m :: * -> *) a. Monad m => m a -> StateT DefState m a
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 (Language 'Valid UpName
l.langInfo.baseDefdLang, Language 'Valid UpName
l.langInfo.originalProgram) of
      (Just Language 'Valid UpDotName
baseLang, Just String
origProg) -> [String] -> String
unlines
        [ String
""
        , String
"This language was generated based on the langauge t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Language 'Valid UpDotName
baseLang.langName.th String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
        , String
"using the following 'Language.Nanopass.deflang' program:"
        , String
""
        , [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"> " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
origProg
        ]
      (Just Language 'Valid UpDotName
baseLang, Maybe String
Nothing) -> [String] -> String
unlines
        [ String
""
        , String
"This language was generated based on the langauge t'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Language 'Valid UpDotName
baseLang.langName.th String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."
        ]
      (Maybe (Language 'Valid UpDotName)
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]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"> " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
origProg
        ]
      (Maybe (Language 'Valid UpDotName)
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 a. a -> StateT DefState Q a
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 :: Production 'Valid -> Define TH.Con
defineProduction :: Production 'Valid -> Define Con
defineProduction Production 'Valid
production = do
  [BangType]
fields <- TypeDesc 'Valid -> Define BangType
defineSubterm (TypeDesc 'Valid -> Define BangType)
-> [TypeDesc 'Valid] -> StateT DefState Q [BangType]
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` Production 'Valid
production.subterms
  Con -> Define Con
forall a. a -> StateT DefState Q a
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 Production 'Valid
production.prodName.th [BangType]
fields

defineSubterm :: TypeDesc 'Valid -> Define TH.BangType
defineSubterm :: TypeDesc 'Valid -> Define BangType
defineSubterm TypeDesc 'Valid
typeDesc = do
  Kind
ty <- TypeDesc 'Valid -> Define Kind
subtermType TypeDesc 'Valid
typeDesc
  BangType -> Define BangType
forall a. a -> StateT DefState Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bang
noBang, Kind
ty)

subtermType :: TypeDesc 'Valid -> Define TH.Type
subtermType :: TypeDesc 'Valid -> Define Kind
subtermType (RecursiveType UpName
nontermName) =
  (DefState -> Maybe Name) -> StateT DefState Q (Maybe Name)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (UpName -> Map UpName Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpName
nontermName (Map UpName Name -> Maybe Name)
-> (DefState -> Map UpName Name) -> DefState -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefState -> Map UpName Name
nontermNames) StateT DefState Q (Maybe Name)
-> (Maybe Name -> Define Kind) -> Define Kind
forall a b.
StateT DefState Q a
-> (a -> StateT DefState Q b) -> StateT DefState Q b
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 a b. (a -> b) -> [a] -> [b]
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 a. a -> StateT DefState Q a
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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. String -> StateT DefState Q a
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 ", UpName -> String
fromUpName UpName
nontermName]
subtermType (VarType Name 'Valid LowName
vName) =
  (DefState -> Bool) -> StateT DefState Q Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Name 'Valid LowName
vName.th Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> 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 a b.
StateT DefState Q a
-> (a -> StateT DefState Q b) -> StateT DefState Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> do
      Kind -> Define Kind
forall a. a -> StateT DefState Q a
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 'Valid LowName
vName.th
    Bool
False -> String -> Define Kind
forall a. String -> StateT DefState Q a
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 'Valid LowName -> String
forall a. Show a => a -> String
show Name 'Valid LowName
vName]
subtermType (CtorType Name 'Valid UpDotName
cName [TypeDesc 'Valid]
argDescs) = do
  Cxt
args <- TypeDesc 'Valid -> Define Kind
subtermType (TypeDesc 'Valid -> Define Kind)
-> [TypeDesc 'Valid] -> StateT DefState Q Cxt
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]
argDescs
  Kind -> Define Kind
forall a. a -> StateT DefState Q a
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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
TH.AppT (Name -> Kind
TH.ConT Name 'Valid UpDotName
cName.th) Cxt
args
subtermType (ListType TypeDesc 'Valid
argDesc) = do
  Kind
arg <- TypeDesc 'Valid -> Define Kind
subtermType TypeDesc 'Valid
argDesc
  Kind -> Define Kind
forall a. a -> StateT DefState Q a
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 'Valid
argDesc) = do
  Kind
neType <- Q Kind -> Define Kind
forall (m :: * -> *) a. Monad m => m a -> StateT DefState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift [t|NonEmpty|]
  Kind
arg <- TypeDesc 'Valid -> Define Kind
subtermType TypeDesc 'Valid
argDesc
  Kind -> Define Kind
forall a. a -> StateT DefState Q a
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 'Valid
argDesc) = do
  Kind
maybeType <- Q Kind -> Define Kind
forall (m :: * -> *) a. Monad m => m a -> StateT DefState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
M.lift [t|Maybe|]
  Kind
arg <- TypeDesc 'Valid -> Define Kind
subtermType TypeDesc 'Valid
argDesc
  Kind -> Define Kind
forall a. a -> StateT DefState Q a
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 TypeDesc 'Valid
UnitType = Kind -> Define Kind
forall a. a -> StateT DefState Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Define Kind) -> Kind -> Define Kind
forall a b. (a -> b) -> a -> b
$ Int -> Kind
TH.TupleT Int
0
subtermType (TupleType TypeDesc 'Valid
t1 TypeDesc 'Valid
t2 [TypeDesc 'Valid]
ts) = do
  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 :: Kind
thTup = Int -> Kind
TH.TupleT Int
tupLen
  Cxt
tys <- TypeDesc 'Valid -> Define Kind
subtermType (TypeDesc 'Valid -> Define Kind)
-> [TypeDesc 'Valid] -> StateT DefState Q Cxt
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
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)
  Kind -> Define Kind
forall a. a -> StateT DefState Q a
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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
TH.AppT Kind
thTup Cxt
tys

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

-- 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 :: UpDotName -> Q (Language 'Valid UpDotName)
reifyLang :: UpDotName -> Q (Language 'Valid UpDotName)
reifyLang UpDotName
lName = do
  (Name
langNameTH, [Con]
nontermPtrs) <- Q (Name, [Con])
findLangInfo
  -- determine the language's grammar types
  [(UpName, Name, [Name], [Con])]
thNonterms <- Con -> Q (UpName, Name, [Name], [Con])
findRecursiveType (Con -> Q (UpName, Name, [Name], [Con]))
-> [Con] -> Q [(UpName, Name, [Name], [Con])]
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` [Con]
nontermPtrs
  let sNames :: [UpName]
sNames = [(UpName, Name, [Name], [Con])]
thNonterms [(UpName, Name, [Name], [Con])]
-> ((UpName, Name, [Name], [Con]) -> UpName) -> [UpName]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(UpName
sName, Name
_, [Name]
_, [Con]
_) -> UpName
sName
  [Nonterm 'Valid]
nontermTypeList <- [(UpName, Name, [Name], [Con])]
-> ((UpName, Name, [Name], [Con]) -> Q (Nonterm 'Valid))
-> Q [Nonterm 'Valid]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(UpName, Name, [Name], [Con])]
thNonterms (((UpName, Name, [Name], [Con]) -> Q (Nonterm 'Valid))
 -> Q [Nonterm 'Valid])
-> ((UpName, Name, [Name], [Con]) -> Q (Nonterm 'Valid))
-> Q [Nonterm 'Valid]
forall a b. (a -> b) -> a -> b
$ \(UpName
nontermName, Name
nontermNameTH, [Name]
paramNames, [Con]
thCtors) -> do
    [Production 'Valid]
ctorList <- [UpName] -> [Name] -> Con -> Q (Production 'Valid)
decodeCtor [UpName]
sNames [Name]
paramNames (Con -> Q (Production 'Valid)) -> [Con] -> Q [Production 'Valid]
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` [Con]
thCtors
    let prodNames :: [Name 'Valid UpName]
prodNames = (.prodName) (Production 'Valid -> Name 'Valid UpName)
-> [Production 'Valid] -> [Name 'Valid UpName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Production 'Valid]
ctorList
        duplicatePNames :: [Name 'Valid UpName]
duplicatePNames = [Name 'Valid UpName]
prodNames [Name 'Valid UpName]
-> [Name 'Valid UpName] -> [Name 'Valid UpName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Name 'Valid UpName] -> [Name 'Valid UpName]
forall a. Eq a => [a] -> [a]
nub [Name 'Valid UpName]
prodNames
    case [Name 'Valid UpName]
duplicatePNames of
      [] -> Nonterm 'Valid -> Q (Nonterm 'Valid)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nonterm
        { $sel:nontermName:Nonterm :: Name 'Valid UpName
nontermName = UpName -> Name -> Name 'Valid UpName
forall n. n -> Name -> Name 'Valid n
ValidName UpName
nontermName Name
nontermNameTH
        , $sel:productions:Nonterm :: Map UpName (Production 'Valid)
productions = [(UpName, Production 'Valid)] -> Map UpName (Production 'Valid)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Production 'Valid]
ctorList [Production 'Valid]
-> (Production 'Valid -> (UpName, Production 'Valid))
-> [(UpName, Production 'Valid)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Production 'Valid
ctor -> (Production 'Valid
ctor.prodName.name, Production 'Valid
ctor))
        }
      [Name 'Valid UpName]
_ -> String -> Q (Nonterm 'Valid)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Nonterm 'Valid)) -> String -> Q (Nonterm 'Valid)
forall a b. (a -> b) -> a -> b
$ String
"corrupt language has duplicate production names: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Name 'Valid UpName] -> String
forall a. Show a => a -> String
show ([Name 'Valid UpName] -> [Name 'Valid UpName]
forall a. Eq a => [a] -> [a]
nub [Name 'Valid UpName]
duplicatePNames)
  -- disallowing duplicates here allows `decodeType.recurse` to produce `RecursiveType`s easily
  let nontermTypes :: [(UpName, Nonterm 'Valid)]
nontermTypes = [Nonterm 'Valid]
nontermTypeList [Nonterm 'Valid]
-> (Nonterm 'Valid -> (UpName, Nonterm 'Valid))
-> [(UpName, Nonterm 'Valid)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Nonterm 'Valid
t -> (Nonterm 'Valid
t.nontermName.name, Nonterm 'Valid
t)
      nontermNames :: [UpName]
nontermNames = (UpName, Nonterm 'Valid) -> UpName
forall a b. (a, b) -> a
fst ((UpName, Nonterm 'Valid) -> UpName)
-> [(UpName, Nonterm 'Valid)] -> [UpName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UpName, Nonterm 'Valid)]
nontermTypes
      duplicateSNames :: [UpName]
duplicateSNames = [UpName]
nontermNames [UpName] -> [UpName] -> [UpName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UpName] -> [UpName]
forall a. Eq a => [a] -> [a]
nub [UpName]
nontermNames
  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
$ [UpName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UpName]
duplicateSNames) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall a. String -> Q a
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 non-terminal names: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [UpName] -> String
forall a. Show a => a -> String
show ([UpName] -> [UpName]
forall a. Eq a => [a] -> [a]
nub [UpName]
duplicateSNames)
  -- determine the language's type parameters
  [Name 'Valid LowName]
langParams <- do
    let f :: Maybe (f String) -> (a, b, f Name, d) -> f (Maybe (f String))
f Maybe (f String)
Nothing (a
_, b
_, f Name
tvs, d
_) = Maybe (f String) -> f (Maybe (f String))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f String -> Maybe (f String)
forall a. a -> Maybe a
Just (f String -> Maybe (f String)) -> f String -> Maybe (f String)
forall a b. (a -> b) -> a -> b
$ Name -> String
fixup (Name -> String) -> f Name -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Name
tvs)
        f (Just f String
tvs) (a
_, b
_, f Name
tvs', d
_)
          | f String
tvs f String -> f String -> Bool
forall a. Eq a => a -> a -> Bool
== (Name -> String
fixup (Name -> String) -> f Name -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Name
tvs') = Maybe (f String) -> f (Maybe (f String))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f String -> Maybe (f String)
forall a. a -> Maybe a
Just f String
tvs)
          | Bool
otherwise = String -> f (Maybe (f String))
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f (Maybe (f String))) -> String -> f (Maybe (f String))
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ f String -> String
forall a. Show a => a -> String
show f String
tvs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
            , String
"got:\n"
            , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ f String -> String
forall a. Show a => a -> String
show (Name -> String
fixup (Name -> String) -> f Name -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Name
tvs')
            ]
    [String]
rawTvs <- [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [String] -> [String]) -> Q (Maybe [String]) -> Q [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe [String]
 -> (UpName, Name, [Name], [Con]) -> Q (Maybe [String]))
-> Maybe [String]
-> [(UpName, Name, [Name], [Con])]
-> Q (Maybe [String])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Maybe [String]
-> (UpName, Name, [Name], [Con]) -> Q (Maybe [String])
forall {f :: * -> *} {f :: * -> *} {a} {b} {d}.
(Eq (f String), MonadFail f, Show (f String), Functor f) =>
Maybe (f String) -> (a, b, f Name, d) -> f (Maybe (f String))
f Maybe [String]
forall a. Maybe a
Nothing [(UpName, Name, [Name], [Con])]
thNonterms
    [String]
-> (String -> Q (Name 'Valid LowName)) -> Q [Name 'Valid LowName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
rawTvs ((String -> Q (Name 'Valid LowName)) -> Q [Name 'Valid LowName])
-> (String -> Q (Name 'Valid LowName)) -> Q [Name 'Valid LowName]
forall a b. (a -> b) -> a -> b
$ \String
rawTv -> case String -> Maybe LowName
toLowName String
rawTv of
      Just LowName
tv -> Name 'Valid LowName -> Q (Name 'Valid LowName)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name 'Valid LowName -> Q (Name 'Valid LowName))
-> Name 'Valid LowName -> Q (Name 'Valid LowName)
forall a b. (a -> b) -> a -> b
$ LowName -> Name -> Name 'Valid LowName
forall n. n -> Name -> Name 'Valid n
ValidName LowName
tv (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ LowName -> String
fromLowName LowName
tv)
      Maybe LowName
Nothing -> String -> Q (Name 'Valid LowName)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name 'Valid LowName))
-> String -> Q (Name 'Valid LowName)
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"corrupt language has non-lowercase type parameter: ", String -> String
forall a. Show a => a -> String
show String
rawTv ]
  -- and we're done
  Language 'Valid UpDotName -> Q (Language 'Valid UpDotName)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Language 'Valid UpDotName -> Q (Language 'Valid UpDotName))
-> Language 'Valid UpDotName -> Q (Language 'Valid UpDotName)
forall a b. (a -> b) -> a -> b
$ Language
    { $sel:langName:Language :: Name 'Valid UpDotName
langName = UpDotName -> Name -> Name 'Valid UpDotName
forall n. n -> Name -> Name 'Valid n
ValidName UpDotName
lName Name
langNameTH
    , $sel:langInfo:Language :: LanguageInfo 'Valid
langInfo = LanguageInfo
      { [Name 'Valid LowName]
langParams :: [Name 'Valid LowName]
$sel:langParams:LanguageInfo :: [Name 'Valid LowName]
langParams
      , $sel:nonterms:LanguageInfo :: Map UpName (Nonterm 'Valid)
nonterms = [(UpName, Nonterm 'Valid)] -> Map UpName (Nonterm 'Valid)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UpName, Nonterm 'Valid)]
nontermTypes
      , $sel:originalProgram:LanguageInfo :: Maybe String
originalProgram = Maybe String
forall a. Maybe a
Nothing
      , $sel:baseDefdLang:LanguageInfo :: Maybe (Language 'Valid UpDotName)
baseDefdLang = Maybe (Language 'Valid UpDotName)
forall a. Maybe a
Nothing
      }
    }
  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 -> String
  fixup :: Name -> String
fixup = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
loop (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (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 :: String -> String
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' = String -> String
loop String
rest
    loop String
other = String
other
  decodeCtor :: [UpName] -> [TH.Name] -> TH.Con -> Q (Production 'Valid)
  decodeCtor :: [UpName] -> [Name] -> Con -> Q (Production 'Valid)
decodeCtor [UpName]
sNames [Name]
paramNames (TH.NormalC Name
prodNameTH [BangType]
thSubterms) = do
    Name 'Valid UpName
prodName <- case String -> Maybe UpName
toUpName (Name -> String
TH.nameBase Name
prodNameTH) of
      Just UpName
x -> Name 'Valid UpName -> Q (Name 'Valid UpName)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name 'Valid UpName -> Q (Name 'Valid UpName))
-> Name 'Valid UpName -> Q (Name 'Valid UpName)
forall a b. (a -> b) -> a -> b
$ UpName -> Name -> Name 'Valid UpName
forall n. n -> Name -> Name 'Valid n
ValidName UpName
x Name
prodNameTH
      Maybe UpName
Nothing -> String -> Q (Name 'Valid UpName)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name 'Valid UpName))
-> String -> Q (Name 'Valid UpName)
forall a b. (a -> b) -> a -> b
$ String
"corrupt language has illegal production name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
prodNameTH
    [TypeDesc 'Valid]
subterms <- [BangType]
-> (BangType -> Q (TypeDesc 'Valid)) -> Q [TypeDesc 'Valid]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [BangType]
thSubterms ((BangType -> Q (TypeDesc 'Valid)) -> Q [TypeDesc 'Valid])
-> (BangType -> Q (TypeDesc 'Valid)) -> Q [TypeDesc 'Valid]
forall a b. (a -> b) -> a -> b
$ \(Bang
_, Kind
thSubtermType) ->
      [UpName] -> [Name] -> Kind -> Q (TypeDesc 'Valid)
decodeType [UpName]
sNames [Name]
paramNames Kind
thSubtermType
    Production 'Valid -> Q (Production 'Valid)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Production 'Valid -> Q (Production 'Valid))
-> Production 'Valid -> Q (Production 'Valid)
forall a b. (a -> b) -> a -> b
$ Production{Name 'Valid UpName
prodName :: Name 'Valid UpName
$sel:prodName:Production :: Name 'Valid UpName
prodName,[TypeDesc 'Valid]
subterms :: [TypeDesc 'Valid]
$sel:subterms:Production :: [TypeDesc 'Valid]
subterms}
  decodeCtor [UpName]
_ [Name]
_ Con
otherCtor = String -> Q (Production 'Valid)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Production 'Valid))
-> String -> Q (Production 'Valid)
forall a b. (a -> b) -> a -> b
$ String
"corrupt production type:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
otherCtor
  decodeType :: [UpName] -> [TH.Name] -> TH.Type -> Q (TypeDesc 'Valid)
  decodeType :: [UpName] -> [Name] -> Kind -> Q (TypeDesc 'Valid)
decodeType [UpName]
sNames [Name]
paramNames Kind
type0 = Kind -> Q (TypeDesc 'Valid)
forall {m :: * -> *}. MonadFail m => Kind -> m (TypeDesc 'Valid)
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 'Valid)
recurse Kind
tuple | Just (Kind
t1:Kind
t2:Cxt
ts) <- Kind -> Maybe Cxt
fromTuple Kind
tuple = do
      TypeDesc 'Valid
t1Desc <- Kind -> m (TypeDesc 'Valid)
recurse Kind
t1
      TypeDesc 'Valid
t2Desc <- Kind -> m (TypeDesc 'Valid)
recurse Kind
t2
      [TypeDesc 'Valid]
tDescs <- Kind -> m (TypeDesc 'Valid)
recurse (Kind -> m (TypeDesc 'Valid)) -> Cxt -> m [TypeDesc 'Valid]
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` Cxt
ts
      TypeDesc 'Valid -> m (TypeDesc 'Valid)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Valid -> m (TypeDesc 'Valid))
-> TypeDesc 'Valid -> m (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ TypeDesc 'Valid
-> TypeDesc 'Valid -> [TypeDesc 'Valid] -> TypeDesc 'Valid
forall (v :: Validate).
TypeDesc v -> TypeDesc v -> [TypeDesc v] -> TypeDesc v
TupleType TypeDesc 'Valid
t1Desc TypeDesc 'Valid
t2Desc [TypeDesc 'Valid]
tDescs
    recurse (TH.AppT (TH.ConT Name
special) Kind
a)
      | Name
special Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe = TypeDesc 'Valid -> TypeDesc 'Valid
forall (v :: Validate). TypeDesc v -> TypeDesc v
MaybeType (TypeDesc 'Valid -> TypeDesc 'Valid)
-> m (TypeDesc 'Valid) -> m (TypeDesc 'Valid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> m (TypeDesc 'Valid)
recurse Kind
a
      | Name
special Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''NonEmpty = TypeDesc 'Valid -> TypeDesc 'Valid
forall (v :: Validate). TypeDesc v -> TypeDesc v
NonEmptyType (TypeDesc 'Valid -> TypeDesc 'Valid)
-> m (TypeDesc 'Valid) -> m (TypeDesc 'Valid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> m (TypeDesc 'Valid)
recurse Kind
a
    recurse (TH.AppT Kind
TH.ListT Kind
a) = TypeDesc 'Valid -> TypeDesc 'Valid
forall (v :: Validate). TypeDesc v -> TypeDesc v
ListType (TypeDesc 'Valid -> TypeDesc 'Valid)
-> m (TypeDesc 'Valid) -> m (TypeDesc 'Valid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> m (TypeDesc 'Valid)
recurse Kind
a
    recurse Kind
appType
      | (TH.ConT Name
thName, Cxt
args) <- Kind -> (Kind, Cxt)
fromApps Kind
appType
      , Just UpName
sName <- String -> Maybe UpName
toUpName (Name -> String
TH.nameBase Name
thName)
      , UpName
sName UpName -> [UpName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UpName]
sNames Bool -> Bool -> Bool
&& Cxt
args Cxt -> Cxt -> Bool
forall a. Eq a => a -> a -> Bool
== Cxt
tvs
        = TypeDesc 'Valid -> m (TypeDesc 'Valid)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Valid -> m (TypeDesc 'Valid))
-> TypeDesc 'Valid -> m (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ UpName -> TypeDesc 'Valid
forall (v :: Validate). UpName -> TypeDesc v
RecursiveType UpName
sName
      | (TH.ConT Name
thName, Cxt
args) <- Kind -> (Kind, Cxt)
fromApps Kind
appType
      , Just UpDotName
cName <- String -> Maybe UpDotName
toUpDotName (Name -> String
TH.nameBase Name
thName) = do
        [TypeDesc 'Valid]
decodedArgs <- Kind -> m (TypeDesc 'Valid)
recurse (Kind -> m (TypeDesc 'Valid)) -> Cxt -> m [TypeDesc 'Valid]
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` Cxt
args
        TypeDesc 'Valid -> m (TypeDesc 'Valid)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Valid -> m (TypeDesc 'Valid))
-> TypeDesc 'Valid -> m (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ Name 'Valid UpDotName -> [TypeDesc 'Valid] -> TypeDesc 'Valid
forall (v :: Validate).
Name v UpDotName -> [TypeDesc v] -> TypeDesc v
CtorType (UpDotName -> Name -> Name 'Valid UpDotName
forall n. n -> Name -> Name 'Valid n
ValidName UpDotName
cName Name
thName) [TypeDesc 'Valid]
decodedArgs
    recurse (TH.VarT Name
thName)
      | Just LowName
tvName <- String -> Maybe LowName
toLowName (Name -> String
TH.nameBase Name
thName)
        = TypeDesc 'Valid -> m (TypeDesc 'Valid)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Valid -> m (TypeDesc 'Valid))
-> TypeDesc 'Valid -> m (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ Name 'Valid LowName -> TypeDesc 'Valid
forall (v :: Validate). Name v LowName -> TypeDesc v
VarType (LowName -> Name -> Name 'Valid LowName
forall n. n -> Name -> Name 'Valid n
ValidName LowName
tvName Name
thName)
    recurse Kind
otherType = String -> m (TypeDesc 'Valid)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (TypeDesc 'Valid)) -> String -> m (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ String
"corrupt subterm type:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
otherType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n in type:\n" String -> String -> String
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 b c a. (b -> c) -> (a, b) -> (a, c)
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 b c a. (b -> c) -> (a, b) -> (a, c)
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 (UpDotName -> String
fromUpDotName UpDotName
lName) Q (Maybe Name)
-> (Maybe Name -> Q (Name, [Con])) -> Q (Name, [Con])
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
Nothing -> String -> Q (Name, [Con])
forall a. String -> Q a
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ UpDotName -> String
fromUpDotName UpDotName
lName
    Just Name
langNameTH -> Name -> Q Info
TH.reify Name
langNameTH Q Info -> (Info -> Q (Name, [Con])) -> Q (Name, [Con])
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TH.TyConI (TH.DataD [] Name
qualThLangName [] Maybe Kind
Nothing [Con]
nontermNames [DerivClause]
_) -> (Name, [Con]) -> Q (Name, [Con])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
qualThLangName, [Con]
nontermNames)
      Info
otherInfo -> String -> Q (Name, [Con])
forall a. String -> Q a
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
langNameTH String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
otherInfo
        ]
  findRecursiveType :: TH.Con -> Q (UpName, TH.Name, [TH.Name], [TH.Con])
  findRecursiveType :: Con -> Q (UpName, Name, [Name], [Con])
findRecursiveType (TH.NormalC Name
thTypePtr []) = do
    let enumPrefix :: String
enumPrefix = (UpName -> String
fromUpName (UpName -> String) -> (UpDotName -> UpName) -> UpDotName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpDotName -> UpName
upDotBase) UpDotName
lName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_"
    UpName
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
base | Just UpName
it <- String -> Maybe UpName
toUpName String
base -> UpName -> Q UpName
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpName
it
        | Bool
otherwise -> String -> Q UpName
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q UpName) -> String -> Q UpName
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ (UpName -> String
fromUpName (UpName -> String) -> (UpDotName -> UpName) -> UpDotName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpDotName -> UpName
upDotBase) UpDotName
lName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is illegal: "
          , String
"  it must be an UpperCaseName, but got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
base
          ]
      Maybe String
Nothing -> String -> Q UpName
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q UpName) -> String -> Q UpName
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ (UpName -> String
fromUpName (UpName -> String) -> (UpDotName -> UpName) -> UpDotName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpDotName -> UpName
upDotBase) UpDotName
lName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not identify a language:\n"
        , String
"  expecting language info enum ctors to start with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
enumPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", but got name: "
        , String
"  " String -> String -> String
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
$ UpDotName -> String
fromUpDotName (UpDotName -> String) -> UpDotName -> String
forall a b. (a -> b) -> a -> b
$ UpDotName -> UpName -> UpDotName
upDotChBase UpDotName
lName UpName
typePtrBase
    Name -> Q Info
TH.reify Name
typePtr Q Info
-> (Info -> Q (UpName, Name, [Name], [Con]))
-> Q (UpName, Name, [Name], [Con])
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TH.TyConI (TH.DataD [] Name
nontermNameTH [TyVarBndr ()]
thParams Maybe Kind
_ [Con]
ctors [DerivClause]
_) -> do
        UpName
nontermName <- case String -> Maybe UpName
toUpName (String -> Maybe UpName) -> String -> Maybe UpName
forall a b. (a -> b) -> a -> b
$ Name -> String
TH.nameBase Name
nontermNameTH of
          Just UpName
x -> UpName -> Q UpName
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpName
x
          Maybe UpName
Nothing -> String -> Q UpName
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q UpName) -> String -> Q UpName
forall a b. (a -> b) -> a -> b
$ String
"corrupt language has illegal non-terminal name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
nontermNameTH
        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 }
        (UpName, Name, [Name], [Con]) -> Q (UpName, Name, [Name], [Con])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpName
nontermName, Name
nontermNameTH, [Name]
thParamNames, [Con]
ctors)
      Info
otherType -> String -> Q (UpName, Name, [Name], [Con])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (UpName, Name, [Name], [Con]))
-> String -> Q (UpName, Name, [Name], [Con])
forall a b. (a -> b) -> a -> b
$ String
"corrupt language non-terminal type:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
otherType
  findRecursiveType Con
otherCtor = String -> Q (UpName, Name, [Name], [Con])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (UpName, Name, [Name], [Con]))
-> String -> Q (UpName, 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ (UpName -> String
fromUpName (UpName -> String) -> (UpDotName -> UpName) -> UpDotName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpDotName -> UpName
upDotBase) UpDotName
lName String -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
otherCtor
    ]

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

runModify :: LangMod -> Q [Dec]
runModify :: LangMod -> Q [Dec]
runModify LangMod
lMod = do
  Language 'Valid UpDotName
oldLang <- UpDotName -> Q (Language 'Valid UpDotName)
reifyLang LangMod
lMod.baseLang
  Language 'Valid UpName
lang' <- case Language 'Valid UpDotName
-> LangMod -> Either Error (Language 'Valid UpName)
extendLang Language 'Valid UpDotName
oldLang LangMod
lMod of
    Right Language 'Valid UpName
ok -> Language 'Valid UpName -> Q (Language 'Valid UpName)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Language 'Valid UpName
ok
    Left Error
err -> String -> Q (Language 'Valid UpName)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Language 'Valid UpName))
-> String -> Q (Language 'Valid UpName)
forall a b. (a -> b) -> a -> b
$ (Text -> String
LT.unpack (Text -> String) -> (Error -> Text) -> Error -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> Text
forall a. Show a => a -> Text
PP.pShow) Error
err -- TODO
  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
$ Language 'Valid UpName -> Define [Dec]
defineLang Language 'Valid UpName
lang'

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

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