nanopass 0.0.2.1 → 0.0.3.0

raw patch · 15 files changed

+1458/−969 lines, 15 filesdep +megaparsecdep +sexpr-parserdep +textdep ~pretty-simplePVP ok

version bump matches the API change (PVP)

Dependencies added: megaparsec, sexpr-parser, text

Dependency ranges changed: pretty-simple

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +134/−122
• app/Lang.hs +13/−7
• app/Main.hs +5/−3
• nanopass.cabal +14/−5
• src/Language/Nanopass/LangDef.hs +131/−299
• src/Language/Nanopass/QQ.hs +34/−357
• src/Language/Nanopass/Xlate.hs +110/−107
• src/Nanopass/Internal.hs +15/−0
• src/Nanopass/Internal/Error.hs +54/−0
• src/Nanopass/Internal/Extend.hs +182/−0
• src/Nanopass/Internal/Parser.hs +421/−0
• src/Nanopass/Internal/Representation.hs +239/−0
• src/Nanopass/Internal/Validate.hs +101/−0
• src/Text/Parse/Stupid.hs +0/−69

@@ -2,6 +2,11 @@  ## 0.0.3.0 -- YYYY-mm-dd +* Stop generating records for each production.+  (This would create partial fields which were a rich source of bugs for clients.)+* Re-wrote internal representation of languages.+* New, more consistent grammar for languages, modifications, and passes.+* Exported internal modules, for the sake of developer documentation only.  ## 0.0.2.1 -- 2024-01-02 

@@ -1,6 +1,7 @@ # Nanopass in Haskell -The original [Nanopass Compiler Framework](https://nanopass.org/) is an domain-specific language embedded in Racket (Scheme), which aids in the construction of maintainable compilers.+The original [Nanopass Compiler Framework](https://nanopass.org/) is a domain-specific language+embedded in Racket (a Scheme dialect), which aids in the construction of maintainable compilers. Its advantages stem from its ability to:   * concisely define a series (in fact, a graph) of slightly-different languages     by describing _modifications_ to other intermediate languages, and@@ -8,7 +9,8 @@     so that the writer of a compiler pass need not supply the boilerplate of repackaging one type's constructor into another's,     but can focus on the interesting parts of the pass. It is suitable for both educational use (students can easily get to the essence of compilation in a few short weeks),-  but also for [production use](http://andykeep.com/pubs/dissertation.pdf).+  but also for [production use](http://andykeep.com/pubs/dissertation.pdf),+  and—I would add—particularly suited to exploring language design space.  In contrast, the best choices available for compiler writers in Haskell require finding a balance between the unreliability induced by moving invariants out of the type system (as in GHC before implementing Trees that Grow), writing significant boilerplate (even the [Trees that Grow](https://www.microsoft.com/en-us/research/uploads/prod/2016/11/trees-that-grow.pdf) approach is significantly more verbose and unnatural than Nanopass), and risking low performance (such as when using generics). @@ -28,14 +30,14 @@ They make the relevant changes to the grammar: ``` e ::= …-   |  let d* in e-d* ::= x = e-    |  x = e; d*+   |  let d in e+d ::= x = e+   |  x = e; d ``` and define a translation from λₗₑₜ to the original λ: ``` ⟦let x = eₓ in e⟧ = (λx. e) eₓ-⟦let x = eₓ; d* in e⟧ = (λx. ⟦let d* in e⟧) eₓ+⟦let x = eₓ; d in e⟧ = (λx. ⟦let d in e⟧) eₓ ```  Why can't we do this in Haskell?@@ -51,13 +53,14 @@ module Lambda where import Language.Nanopass (deflang) -[deflang| Lambda-(Expr-  ( Var String )-  ( Lam {x String} {body $Expr} )-  ( App {f $Expr} {a $Expr} )-)-|]+[deflang|+(Lambda+  (Expr+    (Var String)+    (Lam String Expr)+    (App Expr Expr)+  )+)|] ```  Then, in a separate module, we will define λₗₑₜ by modifying our existing λ implementation.@@ -73,15 +76,19 @@  import qualified Lambda as L0 -[deflang|L0.Lambda :-> LambdaLet-(* Expr-  (+ Let {bind ({String $Expr} +)} {letIn $Expr} )-)-|]+[deflang|+(LambdaLet from L0.Lambda+  (* Expr+    (+ Let+      (+ (& String Expr))+      Expr+    )+  )+)|] ```--Note that here, we got to define a `NonEmpty` list of tuples using the `({String $Expr} +)`.-Even academic authors sometimes don't avail themselves of such data structures, but we eliminated a syntactic category for free!+This says that we will modify the `(* Expr …)` non-terminal by adding a production `(+ Let …)`.+Note that in `(+ (& String Expr))`, we defined a `NonEmpty` with the `+` operator, and a tuple with the `&` operator.+Even academic authors sometimes don't avail themselves of such data structures, but we eliminated a non-terminal for free!  ``` -- This no-op splice separates the two quasiquotes so that the definitions of the@@ -92,16 +99,16 @@ -- language definition. $(pure []) -[defpass|LambdaLet :-> Lambda|]+[defpass|(from LambdaLet to Lambda)|]  compile :: L0.Expr -> Expr-compile = runIdentity . descendExprA xlate+compile = runIdentity . descendExpr xlate   where-  xlate :: XlateA Identity -- type signature unneeded, but included for explanatory purposes-  xlate = XlateA-    -- the exprLet is required because nanopass couldn't find an automatic translation-    { onExprLet = \bind body -> pure $ foldr unlet body bind-    -- the `expr` member allows us to optionally override the default translation when necessary+  xlate :: Xlate Identity -- type signature unneeded, but included for explanatory purposes+  xlate = Xlate+    -- the onExprLet is required because nanopass couldn't find an automatic translation+    { onExprLet = \binds body -> pure $ foldr unlet body binds+    -- the `onExpr` member allows us to optionally override the default translation when necessary     , onExpr = const Nothing -- we don't need to override anything     }   unlet body (x, e) = (Lam x body) `App` e@@ -116,7 +123,9 @@  Something I especially enjoy is that all this metaprogramming generates _bog-standard_ Haskell. The generated code doesn't use any language extensions, and the most sophisticated typeclass it uses is `Traversable`.-The most sophisticated thing we do is pass a record of functions through a recursion, but in all cases this record is defined at the use-site, and so my hope is that inlining and simplification will get rid of any overhead relative to to plain pattern-matching.+The most sophisticated code we generate is to pass a record of functions through a recursion,+  but in practical use, this record is defined near enough to the use-site that+  my hope is that inlining and simplification will get rid of any overhead relative to to plain pattern-matching. My expectation is that the resulting code will be fast because it is the style of code that the compiler most understands.  ## The Full Range of Nanopass@@ -125,25 +134,26 @@ Also, examples alone are not good enough to describe a system; one must have definitions as well.  Nanopass generates sets of mutually-recursive types called languages,-  and also functions to help translate between different languages.+  and also, separately, functions to help translate between different languages. We'll first go over the concepts, and then give the syntax.  ### Languages  A *language* in Nanopass is represented as a set of mutually-recursive types.-One of these generated types is called a *syntactic category*.-Languages can be parameterized, which means that each syntactic category (one of the mutually-recursive types) is parameterized with the same type variables.-Every syntactic category has one or more constructors, called *productions*.-These productions are records, and each member is called a *subterm*.-If a production only has one subterm, it need not specify a name, and the name `un<Production>` will be used.+One of these generated types is called a *non-terminal*.+Languages can be parameterized, which means that each non-terminal is parameterized with the same type variables.+Every non-terminal has one or more constructors, called *productions*.+As each production is just an ordinary Haskell data constructor, they can take arguments, which are called *subterms*.+The subterms can be any sort of Haskell data type, but if it is not a non-terminal, then one could call it a terminal.  Each language is identified by a *language name*.-Under the hood, the language name is also the name of a type with constructors that reference (by name) to the syntactic categories of the language.-Thus, languages names must start with an uppercase letter, and may be qualified.+Under the hood, the language name is also the name of a type with constructors that reference (by name) the non-terminals of the language.+Thus, language names must start with an uppercase letter, and may be qualified. -It is best to define each language in a separate module.+It is best to define each language in a separate module,+  because they commonly share names of data constructors. You will need to export the language type (named after the language name) and all its constructors,-  and you will also need to export each syntactic category (and its constructors).+  and you will also need to export each non-terminal (and its constructors). If the only thing you define in a module is a language, then it's easy enough to just export everything.  ### Translations@@ -152,24 +162,24 @@ However, the common case is that some language terms cannot be automatically translated, and you may also need to do something different from the automatic translation. Thus, the generated functions are parameterized by a type named `Xlate`, which has a member for each   1. *hole*, which is a production in the source language which is altered or missing in the target, and-  2. *override*, which is a syntactic category with the same name in both languages.+  2. *override*, which is a non-terminal with the same name in both languages. This type assumes the translation will occur in an `Applicative` functor. -A translation function is generated for each syntactic category with the same name in both source and target languages.-The name of the translation function is `descend<Syntactic Category>`.+A translation function is generated for each non-terminal with the same name in both source and target languages.+The name of the translation function is `descend<NonTerminal>`. At the moment, there is no provision for altering the name of the type or translation function(s),   but I expect you'll only want to define one translation per module.-The type of a `descend<Syntactic Category>` function is+The type of a `descend<NonTerminal>` function is   `Xlate f → σ → f σ'`.  The `Xlate` type takes all the parameters from both languages (de-duplicating parameters of the same name),   as well as an additional type parameter, which is the functor `f` under which the translation occurs. -If a production in the source language has subterms `τ₁ … τₙ` and is part of the syntactic category `σ`,-  then a hole member is a function of type `τ₁ → … τₙ → f σ'`, where `σ'` is the corresponding syntactic category in the target language.-Essentially, you get access all the subterms, and can use the `Applicative` to generate a target term as long as you don't cross syntactic categories.+If a production in the source language has subterms `τ₁ … τₙ` and is part of the non-terminal `σ`,+  then a hole member is a function of type `τ₁ → … τₙ → f σ'`, where `σ'` is the corresponding non-terminal in the target language.+Essentially, you get access all the subterms, and can use the `Applicative` to generate a target term as long as you don't change the non-terminal type. -If a source language has syntactic category `σ` with the same name as the target's syntactic category `σ'`,+If a source language has non-terminal `σ` with the same name as the target's non-terminal `σ'`,   then an override member is a function of type `σ → Maybe (f σ')`. If an override returns `Nothing`, then the automatic translation will be used,   otherwise the automatic translation is ignored in favor of the result under the `Just`.@@ -178,7 +188,7 @@ The differences are:   * The type `XlateI` is generated; it is not parameterized by `f`, nor are the types of its members.   * The members of `XlateI` are the same as for `Xlate`, but suffixed with the letter `I`.-  * The pure descend functions are named `descend<Syntactic Category>I`.+  * The pure descend functions are named `descend<NonTerminal>I`.     They take an `XlateI` instead of an `Xlate`, and return their results directly rather than under an `Applicative`.   * A function `idXlate` is generated, which takes values of `XlateI` to `Xlate`.     This is only used internally so that the same code paths can be used for both pure and `Applicative` translations.@@ -187,102 +197,104 @@ So, what _can_ be auto-translated? If the subterms of a production don't match, there's nothing we can do, but even when they do match, we can't always generate a translation. Broadly, a subterm can be auto-translated when it mentions other syntactic categories only in `Traversable` position.-  * An auto-translation exists for any subterm which has a type that corresponds to a syntactic category in the target languatge-  * A trivial auto-translation exists when the subterm does not mention any other syntactic categories-  * An auto-translation knows about tuples: as long as every element of the tuple is translatable, the tuple is translatable+  * An auto-translation exists for any subterm which has a type that corresponds to a non-terminal in the target language.+  * A trivial auto-translation exists when the subterm does not mention any other non-terminals.+  * An auto-translation knows about tuples: as long as every element of the tuple is translatable, the tuple is translatable.   * An auto-translation knows about `Traversable`:-    if the only mention of a syntactic category is in the last type argument of a type constructor+    if the only mention of a non-terminal is in the last type argument of a type constructor,       and that type has a `Traversable` instance, we translate using `traverse`.     Importantly, this includes common data structures useful for defining languages,-      such as lists, non-empty lists, `Maybe`, and `Map k` when `k` does not mention a syntactic category.-+      such as lists, non-empty lists, `Maybe`, and `Map k` when `k` does not mention a non-terminal.  I had considered just calling `error` when the automatic translation couldn't be generated. However, this would lead to functions like `case term of { … ; _ -> defaultXlate }`, which hide incomplete pattern match warnings.-By using an `Xlate` type, we maintain warnings whenever part of the translation is not defined; it's just that those warnings are uninitialized member warnings instead.+By using an `Xlate` type, we maintain error detection whenever part of the translation is not defined; it's just that those error are uninitialized strict member errors instead.  ### Syntax -We embed the syntax of the quasiquoters in a modified form of sexprs which allow---and distinguish between---square and curly brackets alongside round brackets.-Atoms are just sequences of characters that don't contain whitespace, though we only recognize a handful of these as valid syntactically.-Importantly, we treat symbols differently based on their shape:-  * `UpCamelCase` is used as in normal Haskell: to identify constructors, both type- and data--  * `$Name` is used for recursive references-  * `lowerCamel` is used for language parameters and the names of terms-  * `DotSeparated.UpCamelCase` is used to qualify the names of languages and types.-  * a handful of operators are used+The syntax in of the quasiquoters is based on s-expressions.+The documentation in `Nanopass.Internal.Parser` is the primary source of truth for how these s-expressions are interpreted,+  but I will replicate them here (just be warned that the readme may fall out of date). -Since the syntax is based on s-expressions, we use [Scheme's entry format](https://schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-4.html#%_sec_1.3.3) conventions for describing the syntax.-Importantly, we syntactic variables are enclosed in `⟨angle brackets⟩`, and ellipsis `⟨thing⟩…` indicate zero or more repetitions of `⟨thing⟩`.-Round, square, and curly brackets, as well as question mark, asterisk, and so on have no special meaning: they only denote themselves.+Of particular note is that s-expressions do not allow dot in a name (as in Haskell qualified names).+Thus, to qualify a name, use a colon instead (`T:Text` in the s-expressions will translate to `T.Text` in Haskell). -The syntax for defining languages, from scratch or by derivation is:++The syntax for requesting a translation is: (TODO this will change in the future) ```-langdef-  ::= ⟨language definition⟩-   |  ⟨language modification⟩+⟨Up.Name⟩ :-> ⟨Up.Name⟩+``` -language definition-  ::= ⟨UpName⟩ ( ⟨lowName⟩… ) ⟨syntactic category⟩…-  ::= ⟨UpName⟩ ⟨syntactic category⟩…+The syntax for defining a language (base or modified) is:+```+Language ::= <BaseLang> | <LangMod> -language modification-  ::= ⟨Up.Name⟩ :-> ⟨UpName⟩ ( ⟨lowName⟩… ) ⟨syntactic category modifier⟩…-   |  ⟨Up.Name⟩ :-> ⟨UpName⟩ ⟨syntactic category modifier⟩…+BaseLang ::=+ (<LangLHS>        language name and type variables+     <string…>     documentation+     <Nonterm…>)   syntactic categories -syntactic category ::= ( ⟨UpName⟩ ⟨production⟩… )-production ::= ( ⟨UpName⟩ ⟨subterm⟩… )-subterm-  ::= { ⟨lowName⟩ ⟨type⟩ }-   |  ⟨type⟩+LangMod ::=+ (<LangLHS>             new language name and type variables+       'from'           keyword+       <UpColon>        base language name+     <string…>          documentation+     <NontermsEdit…>)   changes to the base language's syntactic categories -type-  ::= $⟨UpName⟩                               # reference a syntactic category-   |  ⟨lowName⟩                               # type parameter-   |  ( ⟨Up.Name⟩ ⟨type⟩… )                   # apply a Haskell Type constructor to arguments-   |  ⟨Up.Name⟩                               # same as: (⟨UpName⟩)-   |  ( ⟨type⟩ ⟨type operator⟩… )             # apply common type operators (left-associative)-   |  ( ⟨Up.Name⟩ ⟨type⟩… ⟨type operator⟩… )  # same as: ((⟨UpName⟩ ⟨type⟩…) ⟨type operator⟩…)-   |  { ⟨type⟩ ⟨type⟩ ⟨type⟩… }               # tuple type-   |  [ ⟨type⟩ :-> ⟨type⟩ ]                   # association list: ({⟨type⟩ ⟨type⟩} *)-   |  { ⟨type⟩ :-> ⟨type⟩ }                   # Data.Map+LangLHS ::= <UpCase>                 language name, zero type variables+        |  (<UpCase> <LowCase…>)    language name, type variables -type operator-  ::= *  # []-   |  +  # NonEmpty-   |  ?  # Maybe+------------------------------+------ Base Definitions ------+------------------------------ -syntactic category modifier-  ::= ( + ⟨syntactic category⟩… )   # add-   |  ( - ⟨UpName⟩… )               # remove-   |  ( * ⟨production modifier⟩… )  # modify-production modifier-  ::= ( + ⟨UpName⟩ ⟨subterm⟩… )-   |  ( - ⟨Upname⟩ )-```+Nonterm ::=+ (<UpCase>             type name+     <string…>         documentation+     <Production…>)    constructor arguments -The syntax for requesting a translation is:-```-⟨Up.Name⟩ :-> ⟨Up.Name⟩-```+Production ::=+ (<UpCase>        constructor name+     <string…>    documentation+     <Type…>)     constructor arguments -### What are "Syntactic Categories"?+Type ::= <lowCase name>                 type parameter+     |  <UpColonName>                  plain Haskell type (kind *)+                                       or non-terminal (language parameters already applied)+     |  (<UpColonName> <Type…>)        plain Haskell type application+     |  ('?' <Type>)                   Maybe type+     |  ('*' <Type>)                   List type+     |  ('+' <Type>)                   NonEmpty type+     |  () | ('&')                     unit type+     |  ('&' <Type>)                   Only type TODO+     |  ('&' <Type> <Type> <Type…>)    tuple types -In Nanopass, the line between terminal and non-terminal is blurred, perhaps even erased out of existence.-Context-free grammars can make a clear distinction because they require non-terminals to appear simpliciter in the string of symbols on the rhs of a production.-In contrast, informal descriptions of abstract grammars often use notational convenience---such as list or finite map comprehensions---in defining grammars.+---------------------------+------ Modifications ------+--------------------------- -It's easy to see that the mutually-recursive types defined by the grammar (e.g. `Expr`, `Stmt`) correspond to the notion of non-terminals, and types which have previously been defined (`Int`, `[Char]`) correspond to terminals.-However, there is no technical reason to disallow types such as `[Expr]` (or far more exotic types), where the type constructor has already been defined (like a terminal), but supplied with one of the language's types (like a non-terminal).-Incidentally, the fact that this just works™ lends some credibility to its appearance in the informal definitions common in the academic literature.+NontermsEdit+ ::= ('+'                       add a syntactic category+         <UpCase>                 new non-terminal name+         <string…>                documentation+         <Production…>)           constructors+  |  ('-' <UpCase>)             remove a syntactic category by name+  |  ('*'                       modify a syntactic category's productions+         <UpCase name>            name of non-terminal to edit+         <ProductionsEdit…>)      changes to the base language's non-terminal -Rather than attempt to carve out new, subtle terms, we've decided on "syntactic category" as a catch-all term for terminals, non-terminals and anything in-between.-This term is [already established in the field of linguistics](https://en.wikipedia.org/wiki/Syntactic_category).-At least some\* theories of natural language grammar use the term to collect both lexical categories (which correspond to terminals) and phrasal categories (which correspond to non-terminals), and indeed this is where linguistics and computer science come very close to intersection.-(After all, the Chomsky Hierarchy we learn in a foundations of computation course is named after linguist Noam Chomsky, who made significant contributions to phrase structure grammar, including coining the term.)+ProductionsEdit+ ::= ('+'              add a production+         <UpCase>        new constructor name+         <string…>       documentation+         <Type…>)        constructor arguments+  |  ('-' <UpCase>)    remove a production by name -\*Some other theories dispense entirely with the concept of a phrase, making use of the term moot.+-------------------+------ Names ------+------------------- -Admittedly, "syntactic category" is a mouthful (and a keebful), so in the code I often abbreviate to `syncat`.-If `syncat` makes its way into user-facing documentation, that is a bug and should be reported.-Good technical writing demands that fragments of text be reasonably understandable in isolation, and custom portmanteaus don't help.+LowCase = /[a-z][a-zA-Z0-9_]/+UpCase = /[A-Z][a-zA-Z0-9_]/+UpColonCase = /[A-Z][a-zA-Z0-9_](:[A-Z][a-zA-Z0-9_])*/+```

@@ -13,18 +13,24 @@ data Foo a b c = Foo [c]   deriving (Show,Functor,Foldable,Traversable) -[deflang| L0 (funny)+[deflang|+((L0 funny)   (Expr-    (Var {x String})-    (Lam {x String} {e ($Stmt *)})-    (App {f $Expr} {a $Expr})+    (Var String)+    (Lam String (* Stmt))+    (App Expr Expr)     (Nope String)-    (UhOh {(First $Expr *) ($Expr *) (Foo Int Int $Expr)})+    (UhOh (&+      (* (First Expr))+      (* Expr)+      (Foo (Int) (Int) Expr)+    ))   )   (Stmt-    (Expr {delme funny} $Expr)-    (Let {x String} {e $Expr})+    (Expr funny Expr)+    (Let String Expr)   )+) |] deriving stock instance (Show funny) => Show (Expr funny) deriving stock instance (Show funny) => Show (Stmt funny)

@@ -10,19 +10,21 @@  import qualified Lang as L0 -[deflang| L0.L0 :-> L1+[deflang|+(L1 from L0:L0   (* Expr     (- Lam)-    (+ Lam {x String} {e $Expr})+    (+ Lam String Expr)     (- Nope)   )   (- Stmt)+) |] deriving stock instance Show Expr  $(pure []) -[defpass|L0.L0 :-> L1|]+[defpass|(from L0:L0 to L1)|]  main :: IO () main = do

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: nanopass-version: 0.0.2.1+version: 0.0.3.0 synopsis: Create compilers using small passes and many intermediate representations. description:   Uses Template Haskell to facilitate using a vast number of intermediate representations.@@ -12,7 +12,7 @@ homepage: https://github.com/edemko/nanopass bug-reports: https://github.com/edemko/nanopass/issues author: Marseille Bounchard-maintainer: zankoku.okuno@gmail.com+maintainer: marseillebd@proton.me copyright: 2022 Marseille Bounchard license: BSD-3-Clause license-file: LICENSE@@ -27,19 +27,28 @@   hs-source-dirs: src   exposed-modules:     Language.Nanopass+    Nanopass.Internal+    Nanopass.Internal.Error+    Nanopass.Internal.Extend+    Nanopass.Internal.Parser+    Nanopass.Internal.Representation+    Nanopass.Internal.Validate   other-modules:     Language.Nanopass.LangDef     Language.Nanopass.QQ     Language.Nanopass.Xlate-    Text.Parse.Stupid   build-depends:     , base >=4.11.1 && <4.19     , containers >=0.6 && <0.7+    , megaparsec >=9.2 && <9.3     , mtl >=2.2 && <2.4+    , sexpr-parser >=0.2.2.0 && <0.3     , template-haskell >=2.18 && <2.21+    , text >=2.0 && <2.1+    , pretty-simple >=3.0 && <4.2     , transformers >=0.5.6 && <0.7   default-language: Haskell2010-  ghc-options: -Wall -Wunticked-promoted-constructors+  ghc-options: -Wall -Wpartial-fields -Wunticked-promoted-constructors  executable dumb-nanopass-example   hs-source-dirs: app@@ -54,4 +63,4 @@     , transformers >=0.5.6 && <0.7   default-language: Haskell2010   ghc-options:-    -Wall -Wunticked-promoted-constructors+    -Wall -Wpartial-fields -Wunticked-promoted-constructors

@@ -1,30 +1,22 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE TemplateHaskellQuotes #-}  module Language.Nanopass.LangDef-  ( TypeDesc(..)-  , LangDef(..)-  , SyncatDef(..)-  , ProdDef(..)-  , SubtermDef(..)-  , Define+  ( Define   , runDefine   , defineLang-  , DefdLang(..)-  , DefdSyncatType(..)-  , DefdProd(..)-  , DefdSubterm(..)   , reifyLang-  , LangMod(..)-  , SyncatMod(..)-  , ProdMod(..)   , runModify-  , modifyLang   ) 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 ((<&>))@@ -36,52 +28,20 @@  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--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(Eq,Show)+import qualified Text.Pretty.Simple as PP  --------------------------------- ------ Language Definition ------ --------------------------------- -data LangDef = LangDef-  { langNameReq :: String-  , langParamReqs :: [String]-  , syncatReqs :: [SyncatDef]-  , originalProgram :: Maybe String-  , baseDefdLang :: Maybe DefdLang-  }-  deriving(Show)-data SyncatDef = SyncatDef-  { syncatNameReq :: String-  , productionReqs :: [ProdDef]-  }-  deriving(Show)-data ProdDef = ProdDef-  { prodNameReq :: String-  , subtermReqs :: [SubtermDef]-  }-  deriving(Show)-data SubtermDef = SubtermDef-  { subtermNameReq :: Maybe String-  , subtermTypeReq :: TypeDesc-  }-  deriving(Show)- type Define a = StateT DefState Q a+ data DefState = DefState   { langTyvars :: [TH.Name]-  , syncatNames :: Map String TH.Name+  , nontermNames :: Map UpName TH.Name   }  runDefine :: Define a -> Q a@@ -89,70 +49,69 @@   where   st0 = DefState     { langTyvars = errorWithoutStackTrace "internal nanopass error: uninitialized langTyVars"-    , syncatNames = Map.empty+    , nontermNames = Map.empty     } -defineLang :: LangDef -> Define [Dec]+defineLang :: Language 'Valid UpName -> Define [Dec] defineLang l = do   -- initialize language type variables-  let duplicateParams = l.langParamReqs \\ nub l.langParamReqs+  let duplicateParams = l.langInfo.langParams \\ nub l.langInfo.langParams   if not (null duplicateParams)     then fail $ concat       [ "in a nanopass language definition: "       , "duplicate language parameter names "       , show (nub duplicateParams)       ]-    else modify $ \st -> st{ langTyvars = TH.mkName <$> l.langParamReqs }-  -- initialize syncatNames-  forM_ (syncatNameReq <$> l.syncatReqs) $ \syncatReq -> do-    knownNames <- gets syncatNames-    case Map.lookup syncatReq knownNames of+    else modify $ \st -> st{ langTyvars = (.th) <$> l.langInfo.langParams }+  -- initialize nontermNames+  forM_ l.langInfo.nonterms $ \nonterm -> do+    knownNames <- gets nontermNames+    case Map.lookup nonterm.nontermName.name knownNames of       Nothing -> modify $ \st ->-        st{syncatNames = Map.insert syncatReq (TH.mkName syncatReq) knownNames}+        st{nontermNames = Map.insert nonterm.nontermName.name nonterm.nontermName.th knownNames}       Just _ -> fail $ concat [ "in a nanopass language definition: "-                              , "duplicate syntactic category (terminal/nonterminal) name "-                              , syncatReq+                              , "duplicate non-terminal (terminal/nonterminal) name "+                              , fromUpName nonterm.nontermName.name                               ]   -- define a type with one nullary ctor for every grammatical type-  langInfo <- defineLanginfo l+  langInfo <- defineLangHeader l   -- define every nonterminal type   params <- gets langTyvars <&> \tvs -> tvs <&> \tv -> TH.PlainTV tv ()-  syncatTypeDecs <- forM l.syncatReqs $ \syn -> do-    let syncatName = TH.mkName syn.syncatNameReq-    M.lift $ TH.addModFinalizer $ TH.putDoc (TH.DeclDoc syncatName) $-      "This type is a syntactic category of the t'" ++ l.langNameReq ++ "' language."-    prodCtors <- defineProduction `mapM` syn.productionReqs-    pure $ TH.DataD [] syncatName params Nothing+  nontermTypeDecs <- forM (Map.elems l.langInfo.nonterms) $ \nonterm -> do+    M.lift $ TH.addModFinalizer $ TH.putDoc (TH.DeclDoc nonterm.nontermName.th) $+      "This type is a non-terminal of the t'" ++ fromUpName l.langName.name ++ "' language."+    prodCtors <- defineProduction `mapM` Map.elems nonterm.productions+    pure $ TH.DataD [] nonterm.nontermName.th params Nothing             prodCtors             []-  pure $ langInfo : syncatTypeDecs+  pure $ langInfo : nontermTypeDecs -defineLanginfo :: LangDef -> Define Dec-defineLanginfo l = do-  syncatNames <- gets $ Map.toAscList . syncatNames-  ctors <- forM syncatNames $ \(syncatName, _) -> do-    let ctorName = TH.mkName $ l.langNameReq ++ "_" ++ syncatName+defineLangHeader :: Language 'Valid UpName -> Define Dec+defineLangHeader l = do+  nontermNames <- gets $ Map.toAscList . nontermNames+  ctors <- forM nontermNames $ \(nontermName, _) -> do+    let ctorName = TH.mkName $ fromUpName l.langName.name ++ "_" ++ fromUpName nontermName     M.lift $ TH.addModFinalizer $ TH.putDoc (TH.DeclDoc ctorName) $-      "Serves as a reference to the syntactic category of t'" ++ syncatName ++ "'s."+      "Serves as a reference to the non-terminal of t'" ++ fromUpName nontermName ++ "'s."     pure $ TH.NormalC ctorName []-  let thName = TH.mkName l.langNameReq+  let thName = l.langName.th   M.lift $ TH.addModFinalizer $ TH.putDoc (TH.DeclDoc thName) $ concat     [ unlines       [ "This type is generated by nanopass."       , "It serves as a reference to the types of syntactic categories in the language."       , "Nanopass itself uses types like these to read back in a full language that was defined in a separate splice/quasiquote."       ]-    , case (l.baseDefdLang, l.originalProgram) of-      (Just l0, Just origProg) -> unlines+    , case (l.langInfo.baseDefdLang, l.langInfo.originalProgram) of+      (Just baseLang, Just origProg) -> unlines         [ ""-        , "This language was generated based on the langauge t'" ++ show l0.defdLangName ++ "'"+        , "This language was generated based on the langauge t'" ++ show baseLang.langName.th ++ "'"         , "using the following 'Language.Nanopass.deflang' program:"         , ""         , unlines . fmap ("> " ++) . lines $ origProg         ]-      (Just l0, Nothing) -> unlines+      (Just baseLang, Nothing) -> unlines         [ ""-        , "This language was generated based on the langauge t'" ++ show l0.defdLangName ++ "'."+        , "This language was generated based on the langauge t'" ++ show baseLang.langName.th ++ "'."         ]       (Nothing, Just origProg) -> unlines         [ ""@@ -167,42 +126,33 @@   -- dRead = TH.DerivClause Nothing [TH.ConT ''Read]   pure $ TH.DataD [] thName [] Nothing ctors [] -defineProduction :: ProdDef -> Define TH.Con+defineProduction :: Production 'Valid -> Define TH.Con defineProduction production = do-  let members = production.subtermReqs <&> \case-        SubtermDef (Just explicitName) v -> ("__" ++ explicitName, v)-        SubtermDef Nothing v -> ("__" ++ "un" ++ production.prodNameReq, v)-  let duplicateNames = (fst <$> members) \\ nub (fst <$> members)-  fields <- case duplicateNames of-    [] -> mapM defineSubterm members-    _ -> fail $ concat [ "in a nanopass language definition: "-                       , "the following subterms were defined more than once in a production"-                       , show (nub duplicateNames)-                       ]-  pure $ TH.RecC (TH.mkName production.prodNameReq) fields+  fields <- defineSubterm `mapM` production.subterms+  pure $ TH.NormalC production.prodName.th fields -defineSubterm :: (String, TypeDesc) -> Define TH.VarBangType-defineSubterm (langName, typeDesc) = do+defineSubterm :: TypeDesc 'Valid -> Define TH.BangType+defineSubterm typeDesc = do   ty <- subtermType typeDesc-  pure (TH.mkName langName, noBang, ty)+  pure (noBang, ty) -subtermType :: TypeDesc -> Define TH.Type-subtermType (RecursiveType lName) =-  gets (Map.lookup lName . syncatNames) >>= \case+subtermType :: TypeDesc 'Valid -> Define TH.Type+subtermType (RecursiveType nontermName) =+  gets (Map.lookup nontermName . nontermNames) >>= \case     Just thName -> do       let grammarCtor = TH.ConT thName       params <- gets $ fmap TH.VarT . langTyvars       pure $ foldl TH.AppT grammarCtor params       -- pure $ TH.AppT grammarCtor params-    Nothing -> fail $ concat ["in a nanopass language definition: unknown metavariable ", lName]+    Nothing -> fail $ concat ["in a nanopass language definition: unknown metavariable ", fromUpName nontermName] subtermType (VarType vName) =-  gets ((vName `elem`) . langTyvars) >>= \case+  gets ((vName.th `elem`) . langTyvars) >>= \case     True -> do-      pure $ TH.VarT vName+      pure $ TH.VarT vName.th     False -> fail $ concat ["in a nanopass language definition: unknown langauge parameter ", show vName]-subtermType (CtorType thName argDescs) = do+subtermType (CtorType cName argDescs) = do   args <- subtermType `mapM` argDescs-  pure $ foldl TH.AppT (TH.ConT thName) args+  pure $ foldl TH.AppT (TH.ConT cName.th) args subtermType (ListType argDesc) = do   arg <- subtermType argDesc   pure $ TH.AppT TH.ListT arg@@ -214,74 +164,46 @@   maybeType <- M.lift [t|Maybe|]   arg <- subtermType argDesc   pure $ TH.AppT maybeType arg+subtermType UnitType = pure $ TH.TupleT 0 subtermType (TupleType t1 t2 ts) = do   let tupLen = 2 + length ts       thTup = TH.TupleT tupLen   tys <- subtermType `mapM` (t1:t2:ts)   pure $ foldl TH.AppT thTup tys-subtermType (MapType kDesc vDesc) = do-  m <- M.lift [t|Map|]-  k <- subtermType kDesc-  v <- subtermType vDesc-  pure $ TH.AppT (TH.AppT m k) v  ---------------------------------- ------ Language Reification ------ ---------------------------------- -data DefdLang = DefdLang-  { langQualPrefix :: String -- module name (including the dot before the basename) as requested in LangMod-  , defdLangName :: TH.Name-  , defdLangParams :: [TH.Name]-  , defdSyncats :: Map String DefdSyncatType-  }-  deriving(Show)-data DefdSyncatType = DefdSyncatType-  { defdSyncatName :: TH.Name-  , defdProds :: Map String DefdProd-  }-  deriving(Show)-data DefdProd = DefdProd-  { defdProdName :: TH.Name-  , defdSubterms :: [DefdSubterm]-  }-  deriving(Show)-data DefdSubterm = DefdSubterm-  { defdSubtermName :: TH.Name-  , defdSubtermType :: TypeDesc-  }-  deriving(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 langName = do-  (defdLangName, syncatPtrs) <- findLangInfo+reifyLang :: UpDotName -> Q (Language 'Valid UpDotName)+reifyLang lName = do+  (langNameTH, nontermPtrs) <- findLangInfo   -- determine the language's grammar types-  thSyncats <- findRecursiveType `mapM` syncatPtrs-  let sNames = thSyncats <&> \(qualSName, _, _) -> qualSName-  syncatTypeList <- forM thSyncats $ \(qualSyncatName, paramNames, thCtors) -> do+  thNonterms <- findRecursiveType `mapM` nontermPtrs+  let sNames = thNonterms <&> \(sName, _, _, _) -> sName+  nontermTypeList <- forM thNonterms $ \(nontermName, nontermNameTH, paramNames, thCtors) -> do     ctorList <- decodeCtor sNames paramNames `mapM` thCtors-    let productions = ctorList <&> \ctor -> ((TH.nameBase . defdProdName) ctor, ctor)-        prodNames = fst <$> productions+    let prodNames = (.prodName) <$> ctorList         duplicatePNames = prodNames \\ nub prodNames     case duplicatePNames of-      [] -> pure DefdSyncatType-        { defdSyncatName = qualSyncatName-        , defdProds = Map.fromList productions+      [] -> pure Nonterm+        { nontermName = ValidName nontermName nontermNameTH+        , productions = Map.fromList (ctorList <&> \ctor -> (ctor.prodName.name, ctor))         }       _ -> fail $ "corrupt language has duplicate production names: " ++ show (nub duplicatePNames)   -- disallowing duplicates here allows `decodeType.recurse` to produce `RecursiveType`s easily-  let syncatTypes = syncatTypeList <&> \t -> ((TH.nameBase . defdSyncatName) t, t)-      syncatNames = fst <$> syncatTypes-      duplicateSNames = syncatNames \\ nub syncatNames+  let nontermTypes = nontermTypeList <&> \t -> (t.nontermName.name, t)+      nontermNames = fst <$> nontermTypes+      duplicateSNames = nontermNames \\ nub nontermNames   when (not $ null duplicateSNames) $ fail $-    "corrupt language has duplicate syntactic category names: " ++ show (nub duplicateSNames)+    "corrupt language has duplicate non-terminal names: " ++ show (nub duplicateSNames)   -- determine the language's type parameters-  defdLangParams <--    let f Nothing (_, tvs, _) = pure (Just $ fixup <$> tvs)-        f (Just tvs) (_, tvs', _)+  langParams <- do+    let f Nothing (_, _, tvs, _) = pure (Just $ fixup <$> tvs)+        f (Just tvs) (_, _, tvs', _)           | tvs == (fixup <$> tvs') = pure (Just tvs)           | otherwise = fail $ concat             [ "corrupt language has differing paramaters between syntactic categories. expected:\n"@@ -289,37 +211,41 @@             , "got:\n"             , "  " ++ show (fixup <$> tvs')             ]-     in fromMaybe [] <$> foldM f Nothing thSyncats+    rawTvs <- fromMaybe [] <$> foldM f Nothing thNonterms+    forM rawTvs $ \rawTv -> case toLowName rawTv of+      Just tv -> pure $ ValidName tv (TH.mkName $ fromLowName tv)+      Nothing -> fail $ concat+        [ "corrupt language has non-lowercase type parameter: ", show rawTv ]   -- and we're done-  pure $ DefdLang-    { langQualPrefix-    , defdLangName-    , defdLangParams-    , defdSyncats = Map.fromList syncatTypes+  pure $ Language+    { langName = ValidName lName langNameTH+    , langInfo = LanguageInfo+      { langParams+      , nonterms = Map.fromList nontermTypes+      , originalProgram = Nothing+      , baseDefdLang = 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 -> TH.Name-  fixup = TH.mkName . reverse . loop . reverse . show+  fixup :: TH.Name -> String+  fixup = reverse . loop . reverse . show     where     loop (c:rest)       | c == '_' = rest       | '0' <= c && c <= '9' = loop rest     loop other = other-  langQualPrefix = reverse . dropWhile (/= '.') . reverse $ langName-  langBase = reverse . takeWhile (/= '.') . reverse $ langName-  decodeCtor :: [TH.Name] -> [TH.Name] -> TH.Con -> Q DefdProd-  decodeCtor sNames paramNames (TH.RecC defdProdName thFields) = do-    defdSubterms <- forM thFields $ \(thFieldNameDunder, _, thSubtermType) -> do-      thFieldName <- removeDunder thFieldNameDunder-      typeDesc <- decodeType sNames paramNames thSubtermType-      pure $ DefdSubterm thFieldName typeDesc-    pure $ DefdProd{defdProdName,defdSubterms}-  decodeCtor _ _ (TH.NormalC defdProdName []) =-    pure $ DefdProd{defdProdName,defdSubterms=[]}+  decodeCtor :: [UpName] -> [TH.Name] -> TH.Con -> Q (Production 'Valid)+  decodeCtor sNames paramNames (TH.NormalC prodNameTH thSubterms) = do+    prodName <- case toUpName (TH.nameBase prodNameTH) of+      Just x -> pure $ ValidName x prodNameTH+      Nothing -> fail $ "corrupt language has illegal production name: " ++ show prodNameTH+    subterms <- forM thSubterms $ \(_, thSubtermType) ->+      decodeType sNames paramNames thSubtermType+    pure $ Production{prodName,subterms}   decodeCtor _ _ otherCtor = fail $ "corrupt production type:\n" ++ show otherCtor-  decodeType :: [TH.Name] -> [TH.Name] -> TH.Type -> Q TypeDesc+  decodeType :: [UpName] -> [TH.Name] -> TH.Type -> Q (TypeDesc 'Valid)   decodeType sNames paramNames type0 = recurse type0     where     tvs = TH.VarT <$> paramNames@@ -328,22 +254,22 @@       t2Desc <- recurse t2       tDescs <- recurse `mapM` ts       pure $ TupleType t1Desc t2Desc tDescs-    recurse (TH.AppT (TH.AppT (TH.ConT special) k) v)-      | special == ''Map = MapType <$> recurse k <*> recurse v     recurse (TH.AppT (TH.ConT special) a)       | special == ''Maybe = MaybeType <$> recurse a       | special == ''NonEmpty = NonEmptyType <$> recurse a     recurse (TH.AppT TH.ListT a) = ListType <$> recurse a     recurse appType       | (TH.ConT thName, args) <- fromApps appType-      , thName `elem` sNames && args == 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)-        = pure $ RecursiveType (TH.nameBase thName)-      | (TH.ConT thName, args) <- fromApps appType = do+      , Just sName <- toUpName (TH.nameBase thName)+      , sName `elem` sNames && args == tvs+        = pure $ RecursiveType sName+      | (TH.ConT thName, args) <- fromApps appType+      , Just cName <- toUpDotName (TH.nameBase thName) = do         decodedArgs <- recurse `mapM` args-        pure $ CtorType thName decodedArgs-    recurse (TH.VarT a) = pure $ VarType a+        pure $ CtorType (ValidName cName thName) decodedArgs+    recurse (TH.VarT thName)+      | Just tvName <- toLowName (TH.nameBase thName)+        = pure $ VarType (ValidName tvName thName)     recurse otherType = fail $ "corrupt subterm type:\n" ++ show otherType ++ "\n in type:\n" ++ show type0     fromTuple :: TH.Type -> Maybe [TH.Type]     fromTuple t0 = case loop t0 of@@ -360,33 +286,40 @@       loop (TH.AppT inner lastArg) = second (lastArg:) (loop inner)       loop t = (t, [])   findLangInfo :: Q (TH.Name, [TH.Con]) -- name and constructors of the info type-  findLangInfo = TH.lookupTypeName langName >>= \case-    Nothing -> fail $ "in a nanopass language extension: could not find base language " ++ langName-    Just defdLangName -> TH.reify defdLangName >>= \case-      TH.TyConI (TH.DataD [] qualThLangName [] Nothing syncatNames _) -> pure (qualThLangName, syncatNames)+  findLangInfo = TH.lookupTypeName (fromUpDotName lName) >>= \case+    Nothing -> fail $ "in a nanopass language extension: could not find base language " ++ fromUpDotName lName+    Just langNameTH -> TH.reify langNameTH >>= \case+      TH.TyConI (TH.DataD [] qualThLangName [] Nothing nontermNames _) -> pure (qualThLangName, nontermNames)       otherInfo -> fail $ concat-        [ "in a nanopass language extension: base name " ++ langName ++ " does not identify a language: "+        [ "in a nanopass language extension: base name " ++ show langNameTH ++ " does not identify a language: "         , "  expecting language name to identify data definition, but got this type:\n"         , "  " ++ show otherInfo         ]-  findRecursiveType :: TH.Con -> Q (TH.Name, [TH.Name], [TH.Con])+  findRecursiveType :: TH.Con -> Q (UpName, TH.Name, [TH.Name], [TH.Con])   findRecursiveType (TH.NormalC thTypePtr []) = do-    let enumPrefix = langBase ++ "_"+    let enumPrefix = (fromUpName . upDotBase) lName ++ "_"     typePtrBase <- case stripPrefix enumPrefix (TH.nameBase thTypePtr) of-      Just it -> pure it+      Just base | Just it <- toUpName base -> pure it+        | otherwise -> fail $ concat+          [ "in a nanopass language extension: base name " ++ (fromUpName . upDotBase) lName ++ " is illegal: "+          , "  it must be an UpperCaseName, but got: " ++ base+          ]       Nothing -> fail $ concat-        [ "in a nanopass language extension: base name " ++ langBase ++ " does not identify a language: "-        , "  expecting language info enum ctors to start with " ++ enumPrefix ++ ", but got name:\n"+        [ "in a nanopass language extension: base name " ++ (fromUpName . upDotBase) lName ++ " does not identify a language:\n"+        , "  expecting language info enum ctors to start with " ++ enumPrefix ++ ", but got name: "         , "  " ++ TH.nameBase thTypePtr         ]-    let typePtr = TH.mkName $ langQualPrefix ++ typePtrBase+    let typePtr = TH.mkName $ fromUpDotName $ upDotChBase lName typePtrBase     TH.reify typePtr >>= \case-      TH.TyConI (TH.DataD [] qualSyncatName thParams _ ctors _) -> do+      TH.TyConI (TH.DataD [] nontermNameTH thParams _ ctors _) -> do+        nontermName <- case toUpName $ TH.nameBase nontermNameTH of+          Just x -> pure x+          Nothing -> fail $ "corrupt language has illegal non-terminal name: " ++ show nontermNameTH         let thParamNames = thParams <&> \case { TH.PlainTV it _ -> it ; TH.KindedTV it _ _ -> it }-        pure (qualSyncatName, thParamNames, ctors)-      otherType -> fail $ "corrupt language syntactic category type:\n" ++ show otherType+        pure (nontermName, nontermNameTH, thParamNames, ctors)+      otherType -> fail $ "corrupt language non-terminal type:\n" ++ show otherType   findRecursiveType otherCtor = fail $ concat-    [ "in a nanopass language extension: base name " ++ langName ++ " does not identify a language: "+    [ "in a nanopass language extension: base name " ++ (fromUpName . upDotBase) lName ++ " does not identify a language: "     , "  expecting language name to identify an enum, but got this constructor:\n"     , "  " ++ show otherCtor     ]@@ -395,118 +328,17 @@ ------ Language Extension ------ -------------------------------- -data LangMod = LangMod-  { baseLangReq :: String-  , newLangReq :: String-  , newParamReqs :: [String]-  , syncatMods :: [SyncatMod]-  , originalModProgram :: Maybe String-  }-  deriving(Show)-data SyncatMod-  = AddSyncat SyncatDef-  | DelSyncat String-  | ModProds-    { syncatName :: String-    , prodMods :: [ProdMod]-    }-  deriving(Show)-data ProdMod-  = AddProd ProdDef-  | DelProd String-  deriving(Show)- runModify :: LangMod -> Q [Dec] runModify lMod = do-  oldLang <- reifyLang (baseLangReq lMod)-  modifyLang oldLang lMod--modifyLang :: DefdLang -> LangMod -> Q [Dec]-modifyLang defd mods = do-  defd' <- restrictLang defd (syncatMods mods)-  -- TODO I think it's at this point that I can generate the default translation-  lang' <- extendLang defd' mods+  oldLang <- reifyLang lMod.baseLang+  lang' <- case extendLang oldLang lMod of+    Right ok -> pure ok+    Left err -> fail $ (LT.unpack . PP.pShow) err -- TODO   runDefine $ defineLang lang' -restrictLang :: DefdLang -> [SyncatMod] -> Q DefdLang-restrictLang = foldM doSyncat-  where-  doSyncat :: DefdLang -> SyncatMod -> Q DefdLang-  doSyncat l (AddSyncat _) = pure l-  doSyncat l (DelSyncat sName) = case Map.lookup sName l.defdSyncats of-    Just _ -> pure $ l{ defdSyncats = Map.delete sName l.defdSyncats }-    Nothing -> fail $ concat-      [ "in nanopass language extention: "-      , "attempt to delete non-existent syntactic category "-      , sName ++ " from " ++ show (defdLangName l)-      ]-  doSyncat l (ModProds sName prodMods) = case Map.lookup sName l.defdSyncats of-    Just syncat -> do-      syncat' <- foldM doProds syncat prodMods-      pure l{ defdSyncats = Map.insert sName syncat' l.defdSyncats }-    Nothing -> fail $ concat-      [ "in nanopass language extension: "-      , "attempt to modify non-existent syntactic category "-      , sName ++ " from " ++ show (defdLangName l)-      ]-    where-    doProds :: DefdSyncatType -> ProdMod -> Q DefdSyncatType-    doProds s (AddProd _) = pure s-    doProds s (DelProd pName) = case Map.lookup pName s.defdProds of-      Just _ -> pure $ s{ defdProds = Map.delete pName s.defdProds }-      Nothing -> fail $ concat-        [ "in nanopass language extention: "-        , "attempt to delete non-existent term constructor "-        , sName ++ " from " ++ show s.defdSyncatName ++ " in " ++ show l.defdLangName-        ]--extendLang :: DefdLang -> LangMod -> Q LangDef-extendLang l lMods = do-  syncatReqs0 <- doSyncat lMods.syncatMods `mapM` Map.elems l.defdSyncats-  let syncatReqs = syncatReqs0 ++ catAddSyncat lMods.syncatMods-  pure $ LangDef-    { langNameReq = lMods.newLangReq-    , langParamReqs = lMods.newParamReqs-    , syncatReqs-    , originalProgram = lMods.originalModProgram-    , baseDefdLang = Just l-    }-  where-  doSyncat :: [SyncatMod] -> DefdSyncatType -> Q SyncatDef-  doSyncat gMods DefdSyncatType{defdSyncatName,defdProds} = do-    let productionReqs0 = doProd <$> Map.elems defdProds-    let productionReqs = productionReqs0 ++ catAddProd defdSyncatName gMods-    pure SyncatDef{syncatNameReq = TH.nameBase defdSyncatName, productionReqs}-  doProd :: DefdProd -> ProdDef-  doProd DefdProd{defdProdName, defdSubterms} =-    ProdDef (TH.nameBase defdProdName) (doSubterm <$> defdSubterms)-  doSubterm :: DefdSubterm -> SubtermDef-  doSubterm DefdSubterm{defdSubtermName, defdSubtermType} =-    SubtermDef (Just $ TH.nameBase defdSubtermName) defdSubtermType-  catAddSyncat (AddSyncat s : moreSMods) = s : catAddSyncat moreSMods-  catAddSyncat (_ : moreSMods) = catAddSyncat moreSMods-  catAddSyncat [] = []-  catAddProd thName (ModProds toName prodMods : moreSMods)-    | toName == TH.nameBase thName = go prodMods ++ catAddProd thName moreSMods-    where-    go (AddProd p : morePMods) = p : go morePMods-    go (_ : morePMods) = go morePMods-    go [] = []-  catAddProd thName (_ : morePMods) = catAddProd thName morePMods-  catAddProd _ [] = []-- ------------------------ ------ TH Helpers ------ ------------------------  noBang :: TH.Bang noBang = TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness--removeDunder :: TH.Name -> Q TH.Name-removeDunder name = case TH.nameBase name of-  '_':'_':str -> pure $ TH.mkName str-  other -> fail $ concat-    [ "corrupt subterm field name (must start with double-underscore):\n"-    , "  ", show other-    ]

@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE TupleSections #-}  module Language.Nanopass.QQ@@ -7,94 +8,45 @@   , defpass   ) where -import Data.Char+ import Language.Nanopass.LangDef+import Nanopass.Internal.Representation import Prelude hiding (mod)  -import Control.Monad (forM)+import Data.Functor ((<&>)) import Language.Haskell.TH (Q, Dec) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Nanopass.Xlate (mkXlate)-import Text.Parse.Stupid (Sexpr(..))-+import Nanopass.Internal.Validate (validateLanguage)+import Nanopass.Internal.Parser (Loc(..),parseLanguage,parsePass) +import qualified Data.Text.Lazy as LT import qualified Language.Haskell.TH as TH-import qualified Text.Parse.Stupid as Stupid+import qualified Text.Pretty.Simple as PP  -- | Define a language, either from scratch or by derivation from an existing language.--- The syntax is based on s-expressions. Whitespace doesn't matter, and a (full) line can be commented out with a hash (@#@).--- More details and examples are given in the [readme](https://github.com/edemko/nanopass/blob/master/README.md).------ We embed the syntax of the quasiquoters in a modified form of sexprs which allow---and distinguish between---square and curly brackets alongside round brackets.--- Atoms are just sequences of characters that don't contain whitespace, though we only recognize a handful of these as valid syntactically.--- Importantly, we treat symbols differently based on their shape:------   * @UpCamelCase@ is used as in normal Haskell: to identify constructors, both type- and data----   * @$Name@ is used for recursive references to syntactic categories---   * @lowerCamel@ is used for language parameters and the names of terms---   * @DotSeparated.UpCamelCase@ is used to qualify the names of languages and types.---   * a handful of operators are used--- --- Since the syntax is based on s-expressions, we use [Scheme's entry format](https://schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-4.html#%_sec_1.3.3) conventions for describing the syntax.--- Importantly, we syntactic variables are enclosed in @⟨angle brackets⟩@, and ellipsis @⟨thing⟩…@ indicate zero or more repetitions of @⟨thing⟩@.--- Round, square, and curly brackets, as well as question mark, asterisk, and so on have no special meaning: they only denote themselves.+-- The syntax is based on s-expressions. ----- >  langdef--- >    ::= ⟨language definition⟩--- >     |  ⟨language modification⟩--- >  --- >  language definition--- >    ::= ⟨UpName⟩ ( ⟨lowName⟩… ) ⟨syntactic category⟩…--- >    ::= ⟨UpName⟩ ⟨syntactic category⟩…--- >  --- >  language modification--- >    ::= ⟨Up.Name⟩ :-> ⟨UpName⟩ ( ⟨lowName⟩… ) ⟨syntactic category modifier⟩…--- >     |  ⟨Up.Name⟩ :-> ⟨UpName⟩ ⟨syntactic category modifier⟩…--- >  --- >  syntactic category ::= ( ⟨UpName⟩ ⟨production⟩… )--- >  production ::= ( ⟨UpName⟩ ⟨subterm⟩… )--- >  subterm--- >    ::= { ⟨lowName⟩ ⟨type⟩ }--- >     |  ⟨type⟩--- >  --- >  syntactic category modifier--- >    ::= ( + ⟨syntactic category⟩… )--- >     |  ( - ⟨UpName⟩… )--- >     |  ( * ⟨UpName⟩ ⟨production modifier⟩… )--- >     |  ( * ( ⟨UpName⟩ ⟨production modifier⟩… )… )--- >  production modifier--- >    ::= ( + ⟨UpName⟩ ⟨subterm⟩… )--- >     |  ( - ⟨UpName⟩ )--- >  --- >  type--- >    ::= $⟨UpName⟩                               # reference a syntactic category--- >     |  ⟨lowName⟩                               # type parameter--- >     |  ( ⟨Up.Name⟩ ⟨type⟩… )                   # apply a Haskell Type constructor to arguments--- >     |  ⟨Up.Name⟩                               # same as: (⟨Up.Name⟩)--- >     |  ( ⟨type⟩ ⟨type operator⟩… )             # apply common type operators (left-associative)--- >     |  ( ⟨Up.Name⟩ ⟨type⟩… ⟨type operator⟩… )  # same as: ((⟨UpName⟩ ⟨type⟩…) ⟨type operator⟩…)--- >     |  { ⟨type⟩ ⟨type⟩ ⟨type⟩… }               # tuple type--- >     |  [ ⟨type⟩ :-> ⟨type⟩ ]                   # association list: ({⟨type⟩ ⟨type⟩} *)--- >     |  { ⟨type⟩ :-> ⟨type⟩ }                   # Data.Map--- >  --- >  type operator--- >    ::= *  # []--- >     |  +  # NonEmpty--- >     |  ?  # Maybe+-- TODO document the syntax here, or for now you can look in "Nanopass.Internal.Parser"+-- More details and examples are given in the [readme](https://github.com/edemko/nanopass/blob/master/README.md). deflang :: QuasiQuoter deflang = QuasiQuoter (bad "expression") (bad "pattern") (bad "type") go   where   go :: String -> Q [Dec]   go input = do-    sexprs <- case Stupid.parse input of-      Just it -> pure it-      Nothing -> fail "sexpr syntax error"-    case parseDefBaseOrExt (Just input) sexprs of-      Right (Left def) -> runDefine $ defineLang def-      Right (Right mod) -> runModify mod-      Left err -> fail err-  bad ctx _ = fail $ "`deflang` quasiquoter cannot be used in a " ++ ctx ++ " context,\n\+    loc <- TH.location <&> \l -> Loc+        { file = l.loc_filename+        , line = fst l.loc_start+        , col = snd l.loc_start+        }+    case parseLanguage (loc, input) of+      (Right (Left def)) -> case validateLanguage def of+        Right ok -> runDefine $ defineLang ok+        Left err -> fail $ (LT.unpack . PP.pShow) err -- TODO+      (Right (Right mod)) -> runModify mod+      Left err -> fail $ (LT.unpack . PP.pShow) err -- TODO+  bad ctx _ = fail $ "`deflang` quasiquoter cannot be used in " ++ ctx ++ " context,\n\                      \it can only appear as part of declarations."  -- | Define automatic translation between two langauges.@@ -134,296 +86,21 @@ -- -- More details and examples are given in the [readme](https://github.com/edemko/nanopass/blob/master/README.md). ----- The syntax is:------ >  ⟨Up.Name⟩ :-> ⟨Up.Name⟩+-- TODO document the syntax here, but for now, see 'parsePass' for a grammar. defpass :: QuasiQuoter defpass = QuasiQuoter (bad "expression") (bad "pattern") (bad "type") go   where   go input = do-    sexprs <- case Stupid.parse input of-      Just it -> pure it-      Nothing -> fail "sexpr syntax error"-    case parseDefPass sexprs of-      Right (l1Name, l2Name) -> do-        l1 <- reifyLang l1Name-        l2 <- reifyLang l2Name+    loc <- TH.location <&> \l -> Loc+        { file = l.loc_filename+        , line = fst l.loc_start+        , col = snd l.loc_start+        }+    case parsePass (loc, input) of+      Right ok -> do+        l1 <- reifyLang ok.sourceLang.name+        l2 <- reifyLang ok.targetLang.name         mkXlate l1 l2-      Left err -> fail err+      Left err -> fail $ (LT.unpack . PP.pShow) err -- TODO   bad ctx _ = fail $ "`defpass` quasiquoter cannot be used in a " ++ ctx ++ "context,\n\                      \it can only appear as part of declarations."-  parseDefPass :: [Sexpr String] -> Either String (String, String)-  parseDefPass [Atom l1, Atom ":->", Atom l2]-    | Just l1Name <- fromUpdotname l1-    , Just l2Name <- fromUpdotname l2-      = Right (l1Name, l2Name)-  parseDefPass _ = Left "expecting two language names, separated by :->"------------------------------------------- Language Definitions -------------------------------------------parseDefBaseOrExt :: Maybe String -> [Sexpr String] -> Either String (Either LangDef LangMod)-parseDefBaseOrExt originalText (langName:Atom ":->":rest) = case rest of-  (extName:rest') -> case rest' of-    (candidateParams:rest'') | Right params <- parseParams candidateParams-      -> Right <$> parseLangMod originalText langName extName params rest''-    _ -> Right <$> parseLangMod originalText langName extName [] rest'-  _ -> Left $ "expecting a new language name"-parseDefBaseOrExt originalText (langName:rest) = case rest of-  (candidateParams:rest') | Right params <- parseParams candidateParams-    -> Left <$> parseLangDef originalText langName params rest'-  _ -> Left <$> parseLangDef originalText langName [] rest-parseDefBaseOrExt _ _ = Left $ "expecting a langauge name"--parseParams :: Sexpr String -> Either String [String]-parseParams (Combo "(" params) = parseParam `mapM` params-  where-  parseParam (Atom str) | Just param <- fromLowername str = Right param-  parseParam other = Left $ "expecting type parameter (lowercase symbol), got: " ++ show other-parseParams other = Left $ concat-  [ "expecting parameter list:\n"-  , "  (<lowercase name…> )\n"-  , "got:\n"-  , "  " ++ show other-  ]--parseLangDef :: Maybe String -> Sexpr String -> [String] -> [Sexpr String] -> Either String LangDef-parseLangDef originalProgram nameExpr langParamReqs syncatExprs = do-  langNameReq <- parseLangName nameExpr-  syncatReqs <- parseSyncat `mapM` syncatExprs-  pure $ LangDef-    { langNameReq-    , langParamReqs-    , syncatReqs-    , originalProgram-    , baseDefdLang = Nothing-    }--parseLangName :: Sexpr String -> Either String String-parseLangName (Atom str) | Just str' <- fromUpname str = pure str'-parseLangName _ = Left "language name must be an UpCase alphanumeric symbol"--parseSyncat :: Sexpr String -> Either String SyncatDef-parseSyncat (Combo "(" (nameExpr:prodExprs)) = do-  sName <- case nameExpr of-    (Atom nameStr) | Just sName <- fromUpname nameStr -> pure sName-    _ -> Left $ concat-      [ "expecting an uppercase name of a syntactic category, got:\n"-      , "  " ++ Stupid.print id nameExpr-      ]-  prods <- parseProd `mapM` prodExprs-  pure $ SyncatDef sName prods-parseSyncat other = Left $ concat-  [ "expecting syntactic category definition:\n"-  , "  (<SyncatName> <production>… )\n"-  , "got:\n:"-  , "  " ++ Stupid.print id other-  ]--parseProd :: Sexpr String -> Either String ProdDef-parseProd (Combo "(" (Atom prodStr:subtermExprs))-  | Just prodName <- fromUpname prodStr = do-    subterms <- parseSubterm `mapM` subtermExprs-    pure $ ProdDef prodName subterms-parseProd other = Left $ concat-  [ "expecting a production definition:\n"-  , "  (<ProductionName> <subterm>… )\n"-  , "got:\n"-  , "  " ++ Stupid.print id other-  ]--parseSubterm :: Sexpr String -> Either String SubtermDef-parseSubterm (Combo "{" [Atom fieldStr, typeExpr])-  | Just fieldName <- fromLowername fieldStr = do-    typeDesc <- parseType typeExpr-    pure $ SubtermDef (Just fieldName) typeDesc-parseSubterm typeEexpr = case parseType typeEexpr of-  Right typeDesc -> pure $ SubtermDef Nothing typeDesc-  Left errTy -> Left $ concat-    [ "expecting a subterm definition:\n"-    , "     {<fieldName> <type>}\n"-    , "  or <type>\n"-    , "but parsing <type> failed:\n"-    , unlines . fmap ("  "++) . lines $ errTy-    ]--parseType :: Sexpr String -> Either String TypeDesc-parseType (Atom str)-  | '$':str' <- str-  , Just mutrec <- fromUpname str'-    = pure $ RecursiveType mutrec-  | Just tyvar <- fromLowername str-    = pure $ VarType (TH.mkName tyvar)-  | Just ctorName <- fromUpdotname str = pure $ CtorType (TH.mkName ctorName) []-parseType (Combo "(" subexprs)-  | Just (innerExpr, modifier) <- fromShortcut subexprs = do-      innerType <- parseType innerExpr-      pure $ modifier innerType-  | Just (tycon, argExprs) <- fromTycon subexprs = do-    args <- parseType `mapM` argExprs-    pure $ CtorType (TH.mkName tycon) args-parseType (Combo "[" subexprs)-  | Just (lhsExpr, rhsExpr) <- fromMapType subexprs = do-    lhs <- parseType lhsExpr-    rhs <- parseType rhsExpr-    pure $ ListType (TupleType lhs rhs [])-parseType (Combo "{" subexprs)-  | Just (lhsExpr, rhsExpr) <- fromMapType subexprs = do-    lhs <- parseType lhsExpr-    rhs <- parseType rhsExpr-    pure $ MapType lhs rhs-  | otherwise = parseType `mapM` subexprs >>= \case-    (t1:t2:ts) -> pure $ TupleType t1 t2 ts-    _ -> Left $ concat-      [ "expecting two or more types as part of a tuple, got:\n"-      , unlines $ Stupid.print id <$> subexprs-      ]-parseType other = Left $ concat-  [ "expecting type description, one of:\n"-  , "  $<SyncatName>\n"-  , "  <typeParam>\n"-  , "  <TypeCtor>                # == ($<TypeCtor>)\n"-  , "  (<TypeCtor> <type>… )\n"-  , "  (<type> <* | + | ?>… )    # list, nonempty list, and maybe\n"-  , "  {<type> <type> <type>… }  # tuple\n"-  , "  [ <type> :-> <type> ]     # association list\n"-  , "  { <type> :-> <type> }     # ord map\n"-  , "got:\n"-  , "  " ++ Stupid.print id other-  ]------------------------------------------ Language Extensions ------------------------------------------parseLangMod :: Maybe String -> Sexpr String -> Sexpr String -> [String] -> [Sexpr String] -> Either String LangMod-parseLangMod originalModProgram baseExpr newExpr newParamReqs modExprs = do-  baseLangReq <- parseBaseLangName baseExpr-  newLangReq <- parseLangName newExpr-  modss <- parseSyncatMod `mapM` modExprs-  pure $ LangMod-    { baseLangReq-    , newLangReq-    , newParamReqs-    , syncatMods = concat modss-    , originalModProgram-    }--parseBaseLangName :: Sexpr String -> Either String String-parseBaseLangName (Atom str) | Just str' <- fromUpdotname str = pure str'-parseBaseLangName _ = Left "base language name must be a non-empty list of dot-separated UpCase alphanumeric symbol"--parseSyncatMod :: Sexpr String -> Either String [SyncatMod]-parseSyncatMod (Combo "(" (Atom "+":syncatExprs)) = do-  (fmap AddSyncat . parseSyncat) `mapM` syncatExprs-parseSyncatMod (Combo "(" (Atom "-":syncatExprs)) =-  forM syncatExprs $ \case-    (Atom syncatStr) | Just sName <- fromUpname syncatStr -> pure $ DelSyncat sName-    other -> Left $ "expecting the name of a syntactic category, got:\n  " ++ Stupid.print id other-parseSyncatMod (Combo "(" (Atom "*":Atom sStr:pModExprs))-  | Just sName <- fromUpname sStr = do-    pMods <- parseProdMod `mapM` pModExprs-    pure [ModProds sName pMods]-  | otherwise = Left $ concat-      [ "expecting syntactic category name"-      , ", got: ", show sStr-      ]-parseSyncatMod (Combo "(" (Atom "*":syncatExprs)) =-  forM syncatExprs $ \case-    (Combo "(" (Atom sStr:pModExprs))-      | Just sName <- fromUpname sStr -> do-        pMods <- parseProdMod `mapM` pModExprs-        pure $ ModProds sName pMods-    other -> Left $ concat-      [ "expecting syntactic category modifier:\n"-      , "  (<SyncatName> <ctor mods>… )\n"-      , "got:\n"-      , "  ", Stupid.print id other-      ]-parseSyncatMod other = Left $ concat-  [ "expecting syntactic category modifier batch:\n"-  , "  (+ <syncat modifier>… )\n"-  , "  (* <syncat modifier>… )\n"-  , "  (- <syncat modifier>… )\n"-  , "got:\n"-  , "  " ++ Stupid.print id other-  ]--parseProdMod :: Sexpr String -> Either String ProdMod-parseProdMod (Combo "(" (Atom "+":Atom prodStr:subtermExprs))-  | Just prodName <- fromUpname prodStr = do-    subterms <- parseSubterm `mapM` subtermExprs-    pure $ AddProd $ ProdDef prodName subterms-parseProdMod (Combo "(" [Atom "-", Atom prodStr])-  | Just prodName <- fromUpname prodStr = pure $ DelProd prodName-parseProdMod other = Left $ concat-  [ "expecting a contructor modifier:\n"-  , "  (+ <CtorName> <subterm>… )\n"-  , "  (- <CtorName>)\n"-  , "got:\n"-  , "  " ++ Stupid.print id other-  ]-------------------------------------------- Pattern Match Helpers --------------------------------------------fromTycon :: [Sexpr String] -> Maybe (String, [Sexpr String])-fromTycon (Atom tyconName : argExprs) = do-  tycon <- fromUpdotname tyconName-  pure (tycon, argExprs)-fromTycon _ = Nothing--fromShortcut :: [Sexpr String] -> Maybe (Sexpr String, TypeDesc -> TypeDesc)-fromShortcut exprs0 = case reverse exprs0 of-  yes@(Atom sym:_)-    | sym `elem` (fst <$> shortcuts) -> loop yes-  _ -> Nothing-  where-  loop (Atom sym : rest)-    | Just f' <- lookup sym shortcuts = do-      (inner, f) <- loop rest-      pure (inner, f' . f)-  loop [inner] = pure (inner, id) -- NOTE this is a separate base case b/c we don't want to wrap a metavar in parens-  loop inners@(_:_) = pure (Combo "(" (reverse inners), id)-  loop [] = errorWithoutStackTrace "internal nanopass error in fromShortcut"-  shortcuts =-    [ ("*", ListType)-    , ("+", NonEmptyType)-    , ("?", MaybeType)-    ]--fromMapType :: [Sexpr String] -> Maybe (Sexpr String, Sexpr String)-fromMapType exprs = case break isArrow exprs of-  ([], _) -> Nothing-  (_, []) -> Nothing-  (_, [_]) -> Nothing-  (lhs, _:rhs) ->-    let l = case lhs of { [it] -> it ; _ -> Combo "(" lhs }-        r = case rhs of { [it] -> it ; _ -> Combo "(" rhs }-     in Just (l, r)-  where-  isArrow (Atom ":->") = True-  isArrow _ = False--fromUpdotname :: String -> Maybe String-fromUpdotname inp0 = loop inp0-  where-  loop inp = case break (== '.') inp of-    ([], _) -> Nothing -- no leading dot (or empty string)-    (_, ".") -> Nothing -- no trailing dot-    (_, []) -> Just inp0 -- no more dots-    (_, _:rest) -> loop rest---fromUpname :: String -> Maybe String-fromUpname (c:cs) | isUpper c && all isAlphaNumderscore cs = Just (c:cs)-fromUpname _ = Nothing--fromLowername :: String -> Maybe String-fromLowername (c:cs) | isLower c && all isAlphaNumderscore cs = Just (c:cs)-fromLowername _ = Nothing--isAlphaNumderscore :: Char -> Bool-isAlphaNumderscore c = isAlphaNum c || c == '_'

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}@@ -12,10 +13,10 @@   , XlateProd   , XlateAuto(..)   , XlateHoleDef(..)-  , XlateSyncatDef(..)+  , XlateNontermDef(..)   ) where -import Language.Nanopass.LangDef+import Nanopass.Internal.Representation  import Control.Monad (forM) import Control.Monad.Trans.Maybe (MaybeT(..))@@ -24,7 +25,6 @@ import Data.Functor.Identity (Identity(..)) import Data.List (nub) import Data.List.NonEmpty (NonEmpty)-import Data.Map (Map) import Language.Haskell.TH (Exp(AppE,VarE)) import Language.Haskell.TH (Q,Dec) import Language.Haskell.TH (Type(AppT))@@ -35,10 +35,10 @@ import qualified Language.Haskell.TH.Syntax as TH  -mkXlate :: DefdLang -> DefdLang -> Q [Dec]+mkXlate :: Language 'Valid UpDotName -> Language 'Valid UpDotName -> Q [Dec] mkXlate l1 l2 = xlateDef l1 l2 >>= declareXlate l1 l2 -declareXlate :: DefdLang -> DefdLang -> XlateDef -> Q [Dec]+declareXlate :: Language 'Valid UpDotName -> Language 'Valid UpDotName -> XlateDef -> Q [Dec] declareXlate l1 l2 xlate = do   xlateType <- declareType xlate   xlateTypeI <- declareTypeI xlate@@ -53,89 +53,93 @@ data XlateDef = XlateDef   { xlateParams :: [TH.Name] -- ^ the type parameters of both languages, merged   , xlateFParam :: TH.Name -- ^ a type for an Applicative parameter-  , xlateSyncats :: [XlateSyncatDef]+  , xlateNonterms :: [XlateNontermDef]     -- ^ information about the syntactic cateories shared by both source and target     -- this is used to allow users to override the bahavior of automatic translation-  , xlateProds :: [XlateProd] -- FIXME these should go under xlateSyncats, probly+  , xlateProds :: [XlateProd] -- FIXME these should go under xlateNonterms, probly     -- ^ information about the productions in the source that are missing in the target     -- this is so that we require the user to supply these in an Xlate type-  , xlateFrom :: DefdLang-  , xlateTo :: DefdLang+  , xlateFrom :: Language 'Valid UpDotName+  , xlateTo :: Language 'Valid UpDotName   } type XlateProd = Either XlateHoleDef XlateAuto data XlateAuto = XlateAuto-  { syncatName :: String-  , prodName :: String+  { nontermName :: UpName+  , prodName :: UpName   , autoArgs :: [TH.Name -> TH.Name -> Exp] -- functions from xlate and subterm variables to auto-translator   } data XlateHoleDef = XlateHoleDef-  { syncatName :: String -- the name of the syntactic category shared by source and target-  , prodName :: String -- the name of the source production+  { nontermName :: UpName -- the name of the syntactic category shared by source and target+  , prodName :: UpName -- the name of the source production   , holeArgs :: [TH.Type] -- the types of the subterms of the source production   , holeResult :: TH.Type -- the type of the target syntactic category that must be supplied   }-data XlateSyncatDef = XlateSyncatDef-  { syncatName :: String -- the name of the syntactic category shared by source and target+data XlateNontermDef = XlateNontermDef+  { nontermName :: UpName -- the name of the syntactic category shared by source and target   , fromType :: TH.Type -- parameterized type of the source language at this syntactic category   , toType :: TH.Type -- parameterized type of the target language at this syntactic category   } -xlateDef :: DefdLang -> DefdLang -> Q XlateDef+xlateDef :: Language 'Valid UpDotName -> Language 'Valid UpDotName -> Q XlateDef xlateDef l1 l2 = do-  let xlateParams = nub (l1.defdLangParams ++ l2.defdLangParams)+  let xlateParams = (.th) <$> nub (l1.langInfo.langParams ++ l2.langInfo.langParams)   xlateFParam <- if TH.mkName "f" `elem` xlateParams     then TH.newName "f"     else pure $ TH.mkName "f"-  xlateProds <- fmap concat $ forM (Map.toAscList $ l1.defdSyncats) $ detectHoles l1 l2-  let xlateSyncats = concatMap (detectOverrides l1 l2) $ Map.toAscList l1.defdSyncats+  xlateProds <- fmap concat $ forM (Map.toAscList $ l1.langInfo.nonterms) $ detectHoles l1 l2+  let xlateNonterms = concatMap (detectOverrides l1 l2) $ Map.toAscList l1.langInfo.nonterms   pure $ XlateDef     { xlateParams     , xlateFParam-    , xlateSyncats+    , xlateNonterms     , xlateProds     , xlateFrom = l1     , xlateTo = l2     } -detectHoles :: DefdLang -> DefdLang -> (String, DefdSyncatType) -> Q [Either XlateHoleDef XlateAuto]-detectHoles l1 l2 (sName, s1) = case Map.lookup sName l2.defdSyncats of+detectHoles :: Language 'Valid UpDotName+            -> Language 'Valid UpDotName+            -> (UpName, Nonterm 'Valid)+            -> Q [Either XlateHoleDef XlateAuto]+detectHoles l1 l2 (sName, s1) = case Map.lookup sName l2.langInfo.nonterms of   Nothing -> pure [] -- no translation required: no l2 ctor can use the a type corresponding to this l1 type (because it doesn't exist)-  Just s2 -> fmap concat $ forM (Map.toAscList s1.defdProds) $ detectHoleCtors s2+  Just s2 -> fmap concat $ forM (Map.toAscList s1.productions) $ detectHoleCtors s2   where-  detectHoleCtors :: DefdSyncatType -> (String, DefdProd) -> Q [Either XlateHoleDef XlateAuto]-  detectHoleCtors s2 (pName, prod1) = case Map.lookup pName s2.defdProds of+  detectHoleCtors :: Nonterm 'Valid -> (UpName, Production 'Valid) -> Q [Either XlateHoleDef XlateAuto]+  detectHoleCtors s2 (pName, prod1) = case Map.lookup pName s2.productions of     -- a required hole, because there is no constructor to target     Nothing -> pure [Left $ createHole pName prod1]     Just prod2       -- no custom translation required: the arguments of one constructor match up with the arguments of the other-      | tys1 <- (defdSubtermType <$> prod1.defdSubterms)-      , tys2 <- (defdSubtermType <$> prod2.defdSubterms)+      | tys1 <- prod1.subterms+      , tys2 <- prod2.subterms       , tys1 == tys2 -> runMaybeT (createAuto `mapM` tys1) >>= \case           Nothing -> pure [Left $ createHole pName prod1] -- a required hole because no auto-translation possible           Just autoArgs -> do-            pure [Right XlateAuto{syncatName=sName,prodName=pName,autoArgs}]+            pure [Right XlateAuto{nontermName=sName,prodName=pName,autoArgs}]       -- a required hole, because the arguments of the constructors do not have the same structure       | otherwise  -> pure [Left $ createHole pName prod1]+  createHole :: UpName -> Production 'Valid -> XlateHoleDef   createHole pName prod1 =-    let holeArgs = flip map (defdSubterms prod1) $ \subterm ->-          interpretTypeDesc l1 subterm.defdSubtermType-        holeCtor = TH.ConT (TH.mkName $ l2.langQualPrefix ++ sName)-        holeResult = foldl AppT holeCtor (TH.VarT <$> l2.defdLangParams)-     in XlateHoleDef{syncatName=sName,prodName=pName,holeArgs,holeResult}+    let holeArgs = flip map prod1.subterms $ \subterm ->+          interpretTypeDesc l1 subterm+        holeCtor = TH.ConT (TH.mkName $ fromUpDotName (upDotChBase l2.langName.name sName))+        holeResult = foldl AppT holeCtor (TH.VarT . (.th) <$> l2.langInfo.langParams)+     in XlateHoleDef{nontermName=sName,prodName=pName,holeArgs,holeResult} -detectOverrides :: DefdLang -> DefdLang -> (String, DefdSyncatType) -> [XlateSyncatDef]-detectOverrides l1 l2 (sName, _) = case Map.lookup sName l2.defdSyncats of+detectOverrides :: Language 'Valid UpDotName -> Language 'Valid UpDotName -> (UpName, Nonterm 'Valid) -> [XlateNontermDef]+detectOverrides l1 l2 (sName, _) = case Map.lookup sName l2.langInfo.nonterms of   Nothing -> [] -- no translation required: no l2 ctor can use the a type corresponding to this l1 type (because it doesn't exist)   Just _ ->-    let fromTypeCtor = TH.ConT (TH.mkName $ l1.langQualPrefix ++ sName)-        fromType = foldl AppT fromTypeCtor (TH.VarT <$> l1.defdLangParams)-        toTypeCtor = TH.ConT (TH.mkName $ l2.langQualPrefix ++ sName)-        toType = foldl AppT toTypeCtor (TH.VarT <$> l2.defdLangParams)-     in [XlateSyncatDef{syncatName = sName,fromType,toType}]+    let fromTypeCtor = TH.ConT (TH.mkName $ fromUpDotName (upDotChBase l1.langName.name sName))+        fromType = foldl AppT fromTypeCtor (TH.VarT . (.th) <$> l1.langInfo.langParams)+        toTypeCtor = TH.ConT (TH.mkName $ fromUpDotName (upDotChBase l2.langName.name sName))+        toType = foldl AppT toTypeCtor (TH.VarT . (.th) <$> l2.langInfo.langParams)+     in [XlateNontermDef{nontermName = sName,fromType,toType}] -createAuto :: TypeDesc -> MaybeT Q (TH.Name -> TH.Name -> Exp)+createAuto :: TypeDesc 'Valid -> MaybeT Q (TH.Name -> TH.Name -> Exp) createAuto (RecursiveType sName) = do-  let repName = TH.mkName $ "descend" ++ sName+  let repName = TH.mkName $ "descend" ++ fromUpName sName       auto xlateVar argVar = VarE repName `AppE` VarE xlateVar `AppE` VarE argVar   pure auto createAuto (VarType _) = do@@ -147,7 +151,7 @@     pure auto   | t:ts' <- reverse ts   , all (not . containsGrammar) ts' = do-      let travCandidate = foldl AppT (TH.ConT tyName) (interpretTypeDesc undefined <$> ts')+      let travCandidate = foldl AppT (TH.ConT tyName.th) (interpretTypeDesc (Language undefined undefined) <$> ts')       isTraversable <- M.lift $ TH.isInstance ''Traversable [travCandidate]       if isTraversable then traversableAuto t else hoistNothing   -- TODO maybe try Bitraversable@@ -155,6 +159,9 @@ createAuto (ListType t) = traversableAuto t createAuto (MaybeType t) = traversableAuto t createAuto (NonEmptyType t) = traversableAuto t+createAuto UnitType = do+  let auto _ _ = VarE 'pure `AppE` TH.TupE []+  pure auto createAuto (TupleType t1 t2 ts) = do   tupleMaker <- do     tVars <- forM [1..length (t1:t2:ts)] $ \i -> M.lift $ TH.newName ("t" ++ show i)@@ -169,11 +176,8 @@               foldl idiomAppE (AppE (VarE 'pure) tupleMaker) (zipWith elemAuto autos' args')          in lam `AppE` VarE argVar   pure auto-createAuto (MapType k v)-  | not (containsGrammar k) = traversableAuto v-  | otherwise = hoistNothing -traversableAuto :: TypeDesc -> MaybeT Q (TH.Name -> TH.Name -> Exp)+traversableAuto :: TypeDesc 'Valid -> MaybeT Q (TH.Name -> TH.Name -> Exp) traversableAuto t = do   var <- M.lift $ TH.newName "x"   auto' <- createAuto t@@ -202,31 +206,31 @@     , "    When no override is needed, these members can be initialized with 'const Nothing'."     ]   holes <- forM (lefts $ xlateProds x) $ \hole -> do-    let name = TH.mkName $ "on" ++ hole.syncatName ++ hole.prodName+    let name = TH.mkName $ "on" ++ fromUpName hole.nontermName ++ fromUpName hole.prodName         r = TH.VarT x.xlateFParam `AppT` hole.holeResult         t = foldr ArrT r hole.holeArgs     TH.addModFinalizer $ TH.putDoc (TH.DeclDoc name) $ unlines       [ "No automatic translation for"       , concat-        [ "the v'", x.xlateFrom.langQualPrefix ++ hole.prodName, "' production "-        , "of t'", x.xlateFrom.langQualPrefix ++ hole.syncatName, "'"+        [ "the v'", fromUpDotName (upDotChBase x.xlateFrom.langName.name hole.prodName), "' production "+        , "of t'", fromUpDotName (upDotChBase x.xlateFrom.langName.name hole.nontermName), "'"         ]       , "could be generated by Nanopass."       ]     pure (name, bang, t)-  overrides <- forM x.xlateSyncats $ \syncat -> do-    let name = TH.mkName $ "on" ++ syncat.syncatName-        r = TH.ConT ''Maybe `AppT` (TH.VarT x.xlateFParam `AppT` syncat.toType)+  overrides <- forM x.xlateNonterms $ \nonterm -> do+    let name = TH.mkName $ "on" ++ fromUpName nonterm.nontermName+        r = TH.ConT ''Maybe `AppT` (TH.VarT x.xlateFParam `AppT` nonterm.toType)     TH.addModFinalizer $ TH.putDoc (TH.DeclDoc name) $ unlines       [ "This member allows you to override the default translation for"       , unwords-        [ "The", "t'" ++ x.xlateFrom.langQualPrefix ++ syncat.syncatName ++ "'"+        [ "The", "t'" ++ fromUpDotName (upDotChBase x.xlateFrom.langName.name nonterm.nontermName) ++ "'"         , "syntactic category."         ]       , "Produce a 'Just' value to override the automatic translation."       , "If no overrides are needed, use @'const' 'Nothing'@."       ]-    pure (name, bang, ArrT syncat.fromType r)+    pure (name, bang, ArrT nonterm.fromType r)   pure $ TH.DataD [] xlateName tvs Nothing     [TH.RecC xlateName $ holes ++ overrides]     []@@ -243,30 +247,30 @@     , "See 'Xlate' for more detail."     ]   holes <- forM (lefts x.xlateProds) $ \hole -> do-    let name = TH.mkName $ "on" ++ hole.syncatName ++ hole.prodName ++ "I"+    let name = TH.mkName $ "on" ++ fromUpName hole.nontermName ++ fromUpName hole.prodName ++ "I"         t = foldr ArrT hole.holeResult hole.holeArgs     TH.addModFinalizer $ TH.putDoc (TH.DeclDoc name) $ unlines       [ "No automatic translation for"       , concat-        [ "the v'", x.xlateFrom.langQualPrefix ++ hole.prodName, "' production "-        , "of t'", x.xlateFrom.langQualPrefix ++ hole.syncatName, "'"+        [ "the v'", fromUpDotName (upDotChBase x.xlateFrom.langName.name hole.prodName), "' production "+        , "of t'", fromUpDotName (upDotChBase x.xlateFrom.langName.name hole.nontermName), "'"         ]       , "could be generated by Nanopass."       ]     pure (name, bang, t)-  overrides <- forM x.xlateSyncats $ \syncat -> do-    let name = TH.mkName $ "on" ++ syncat.syncatName ++ "I"-        r = TH.ConT ''Maybe `AppT` syncat.toType+  overrides <- forM x.xlateNonterms $ \nonterm -> do+    let name = TH.mkName $ "on" ++ fromUpName nonterm.nontermName ++ "I"+        r = TH.ConT ''Maybe `AppT` nonterm.toType     TH.addModFinalizer $ TH.putDoc (TH.DeclDoc name) $ unlines       [ "This member allows you to override the default translation for"       , unwords-        [ "The", "t'" ++ x.xlateFrom.langQualPrefix ++ syncat.syncatName ++ "'"+        [ "The", "t'" ++ fromUpDotName (upDotChBase x.xlateFrom.langName.name nonterm.nontermName) ++ "'"         , "syntactic category."         ]       , "Produce a 'Just' value to override the automatic translation."       , "If no overrides are needed, use @'const' 'Nothing'@."       ]-    pure (name, bang, ArrT syncat.fromType r)+    pure (name, bang, ArrT nonterm.fromType r)   pure $ TH.DataD [] xlateName tvs Nothing     [TH.RecC xlateName $ holes ++ overrides]     []@@ -300,60 +304,55 @@     ]   where   holes xlateVar = forM (lefts x.xlateProds) $ \hole -> do-    let nameAp = TH.mkName $ "on" ++ hole.syncatName ++ hole.prodName-        nameId = TH.mkName $ "on" ++ hole.syncatName ++ hole.prodName ++ "I"+    let nameAp = TH.mkName $ "on" ++ fromUpName hole.nontermName ++ fromUpName hole.prodName+        nameId = TH.mkName $ "on" ++ fromUpName hole.nontermName ++ fromUpName hole.prodName ++ "I"     subtermNames <- forM hole.holeArgs $ \_ -> do       TH.newName "subterm"     let lam = TH.LamE (TH.VarP <$> subtermNames) body         body = TH.ConE 'Identity `AppE` foldl AppE delegate (TH.VarE <$> subtermNames)         delegate = TH.VarE nameId `AppE` TH.VarE xlateVar     pure (nameAp, lam)-  overrides xlateVar = forM x.xlateSyncats $ \syncat -> do-    let nameAp = TH.mkName $ "on" ++ syncat.syncatName-        nameId = TH.mkName $ "on" ++ syncat.syncatName ++ "I"+  overrides xlateVar = forM x.xlateNonterms $ \nonterm -> do+    let nameAp = TH.mkName $ "on" ++ fromUpName nonterm.nontermName+        nameId = TH.mkName $ "on" ++ fromUpName nonterm.nontermName ++ "I"     varName <- TH.newName "term0"     let lam = TH.LamE [TH.VarP varName] body         body = TH.InfixE (Just $ TH.ConE 'Identity) (TH.VarE '(<$>)) (Just delegate)         delegate = (TH.VarE nameId `AppE` TH.VarE xlateVar) `AppE` TH.VarE varName     pure (nameAp, lam) -interpretTypeDesc :: DefdLang -> TypeDesc -> TH.Type+interpretTypeDesc :: Language 'Valid UpDotName -> TypeDesc 'Valid -> TH.Type interpretTypeDesc l = go   where   go (RecursiveType sName) =-    let syncatCtor = TH.ConT (TH.mkName $ l.langQualPrefix ++ sName)-     in foldl AppT syncatCtor (TH.VarT <$> l.defdLangParams)-  go (VarType vName) = TH.VarT vName-  go (CtorType thName argDescs) = foldl AppT (TH.ConT thName) (go <$> argDescs)+    let nontermCtor = TH.ConT (TH.mkName . fromUpDotName $ upDotChBase l.langName.name sName)+     in foldl AppT nontermCtor (TH.VarT . (.th) <$> l.langInfo.langParams)+  go (VarType vName) = TH.VarT vName.th+  go (CtorType thName argDescs) = foldl AppT (TH.ConT thName.th) (go <$> argDescs)   go (ListType argDesc) = AppT TH.ListT (go argDesc)   go (NonEmptyType argDesc) = AppT (TH.ConT ''NonEmpty) (go argDesc)   go (MaybeType argDesc) = AppT (TH.ConT ''Maybe) (go argDesc)+  go UnitType = TH.TupleT 0   go (TupleType t1 t2 ts) =     let tupLen = 2 + length ts         thTup = TH.TupleT tupLen         tys = go <$> (t1:t2:ts)      in foldl AppT thTup tys-  go (MapType kDesc vDesc) = do-    let m = TH.ConT ''Map-        k = go kDesc-        v = go vDesc-     in AppT (AppT m k) v - --------------------------------------- ------ Declare Descend Functions ------ --------------------------------------- -defineDescend :: DefdLang -> DefdLang -> XlateDef -> Q [Dec]+defineDescend :: Language 'Valid UpDotName -> Language 'Valid UpDotName -> XlateDef -> Q [Dec] defineDescend l1 l2 xdef = do-  fmap concat . forM xdef.xlateSyncats $ \XlateSyncatDef{syncatName} -> do-    let funName = TH.mkName $ "descend" ++ syncatName-        funNameId = TH.mkName $ "descend" ++ syncatName ++ "I"+  fmap concat . forM xdef.xlateNonterms $ \XlateNontermDef{nontermName} -> do+    let funName = TH.mkName $ "descend" ++ fromUpName nontermName+        funNameId = TH.mkName $ "descend" ++ fromUpName nontermName ++ "I"     TH.addModFinalizer $ TH.putDoc (TH.DeclDoc funName) $ unlines       [ unwords         [ "Translate syntax trees starting from"-        , "any t'" ++ l1.langQualPrefix ++ syncatName ++ "' of the t'" ++ show l1.defdLangName ++ "' language"-        , "to the corresponding '" ++ l2.langQualPrefix ++ syncatName ++ "' of the t'" ++ show l2.defdLangName ++ "' language."+        , "any t'" ++ fromUpDotName (upDotChBase l1.langName.name nontermName) ++ "' of the t'" ++ show l1.langName.th ++ "' language"+        , "to the corresponding '" ++ fromUpDotName (upDotChBase l2.langName.name nontermName) ++ "' of the t'" ++ show l2.langName.th ++ "' language."         ]       , ""       , "Some (hopefully most) of this function was automatically generated by nanopass."@@ -366,8 +365,8 @@     TH.addModFinalizer $ TH.putDoc (TH.DeclDoc funNameId) $ unlines       [ unwords         [ "Translate syntax trees starting from"-        , "any t'" ++ l1.langQualPrefix ++ syncatName ++ "' of the t'" ++ show l1.defdLangName ++ "' language"-        , "to the corresponding '" ++ l2.langQualPrefix ++ syncatName ++ "' of the t'" ++ show l2.defdLangName ++ "' language."+        , "any t'" ++ fromUpDotName (upDotChBase l1.langName.name nontermName) ++ "' of the t'" ++ show l1.langName.th ++ "' language"+        , "to the corresponding '" ++ fromUpDotName (upDotChBase l2.langName.name nontermName) ++ "' of the t'" ++ show l2.langName.th ++ "' language."         ]       , ""       , "This is the pure (i.e. no 'Applicative' required) version of '"++show funName++"'."@@ -377,22 +376,21 @@     xlateVar <- TH.newName "xlate"     termVar <- TH.newName "term"     -- define the automatic case matching-    autoMatches <- case Map.lookup syncatName l1.defdSyncats of-      Nothing -> errorWithoutStackTrace $ "nanopass internal error: failed to find a source syncat that appears as an override: " ++ syncatName-      Just DefdSyncatType{defdProds} -> do+    autoMatches <- case Map.lookup nontermName l1.langInfo.nonterms of+      Nothing -> errorWithoutStackTrace $ "nanopass internal error: failed to find a source nonterm that appears as an override: " ++ fromUpName nontermName+      Just Nonterm{productions} -> do         -- go through all the productions for this syntactic category's type-        forM (Map.toAscList defdProds) $ \(_, prod) -> do-          let pName = TH.nameBase prod.defdProdName-          args <- (TH.newName . TH.nameBase . defdSubtermName) `mapM` prod.defdSubterms-          let pat = TH.ConP prod.defdProdName [] (TH.VarP <$> args)-          let body = case findAuto syncatName pName xdef.xlateProds of+        forM (Map.toAscList productions) $ \(_, prod) -> do+          args <- TH.newName `mapM` take (length prod.subterms) base26+          let pat = TH.ConP prod.prodName.th [] (TH.VarP <$> args)+          let body = case findAuto nontermName prod.prodName.name xdef.xlateProds of                 -- if this production has a hole, call the hole                 Just (Left _) ->-                  let f = TH.mkName $ "on" ++ syncatName ++ pName+                  let f = TH.mkName $ "on" ++ fromUpName nontermName ++ fromUpName prod.prodName.name                       recurse = VarE f `AppE` VarE xlateVar                    in foldl AppE recurse (VarE <$> args)                 Just (Right auto) ->-                  let e0 = VarE 'pure `AppE` TH.ConE (TH.mkName $ l2.langQualPrefix ++ pName)+                  let e0 = VarE 'pure `AppE` TH.ConE (TH.mkName . fromUpDotName $ upDotChBase l2.langName.name prod.prodName.name)                       iAppE a b = TH.InfixE (Just a) (VarE '(<*>)) (Just b)                       es = zipWith ($) (auto.autoArgs <&> ($ xlateVar)) args                    in foldl iAppE e0 es@@ -401,7 +399,7 @@     let autoBody = TH.CaseE (VarE termVar) autoMatches     -- define the case match on the result of the override     termVar' <- TH.newName "term"-    let override = VarE (TH.mkName $ "on" ++ syncatName)+    let override = VarE (TH.mkName $ "on" ++ fromUpName nontermName)                    `AppE` (VarE xlateVar)                    `AppE` (VarE termVar)         ovrMatches =@@ -419,10 +417,10 @@         appClass = TH.ConT ''Applicative `AppT` TH.VarT xdef.xlateFParam         xlateArgTyCon = TH.ConT $ TH.mkName "Xlate"         xlateArgTy = foldl AppT xlateArgTyCon (TH.VarT <$> xdef.xlateParams ++ [xdef.xlateFParam])-        l1ArgTyCon = TH.ConT $ TH.mkName $ l1.langQualPrefix ++ syncatName-        l1ArgTy = foldl AppT l1ArgTyCon (TH.VarT <$> l1.defdLangParams)-        l2ResTyCon = TH.ConT $ TH.mkName $ l2.langQualPrefix ++ syncatName-        l2ResTyCore = foldl AppT l2ResTyCon (TH.VarT <$> l2.defdLangParams)+        l1ArgTyCon = TH.ConT $ TH.mkName . fromUpDotName $ upDotChBase l1.langName.name nontermName+        l1ArgTy = foldl AppT l1ArgTyCon (TH.VarT . (.th) <$> l1.langInfo.langParams)+        l2ResTyCon = TH.ConT $ TH.mkName . fromUpDotName $ upDotChBase l2.langName.name nontermName+        l2ResTyCore = foldl AppT l2ResTyCon (TH.VarT . (.th) <$> l2.langInfo.langParams)         l2ResTy = AppT (TH.VarT xdef.xlateFParam) l2ResTyCore     let quantifierId = flip TH.PlainTV TH.InferredSpec <$> xdef.xlateParams         xlateArgTyConId = TH.ConT $ TH.mkName "XlateI"@@ -452,24 +450,29 @@ bang :: TH.Bang bang = TH.Bang TH.NoSourceUnpackedness TH.SourceStrict -containsGrammar :: TypeDesc -> Bool+containsGrammar :: TypeDesc 'Valid -> Bool containsGrammar (RecursiveType _) = True containsGrammar (VarType _) = False containsGrammar (CtorType _ ts) = any containsGrammar ts containsGrammar (ListType t) = containsGrammar t containsGrammar (MaybeType t) = containsGrammar t containsGrammar (NonEmptyType t) = containsGrammar t+containsGrammar UnitType = False containsGrammar (TupleType t1 t2 ts) = any containsGrammar (t1:t2:ts)-containsGrammar (MapType t1 t2) = containsGrammar t1 || containsGrammar t2 -findAuto :: String -> String -> [XlateProd] -> Maybe XlateProd+findAuto :: UpName -> UpName -> [XlateProd] -> Maybe XlateProd findAuto sName pName autosHoles = case filter f autosHoles of   [] -> Nothing   x:_ -> Just x   where   f :: XlateProd -> Bool-  f (Left x) = x.syncatName == sName && x.prodName == pName-  f (Right x) = x.syncatName == sName && x.prodName == pName+  f (Left x) = x.nontermName == sName && x.prodName == pName+  f (Right x) = x.nontermName == sName && x.prodName == pName  hoistNothing :: Monad m => MaybeT m a hoistNothing = MaybeT $ pure Nothing++base26 :: [String]+base26 = concat $ digits <$> ([0..] :: [Int])+  where+  digits n = (:) <$> ['a'..'z'] <*> (if n == 0 then pure "" else digits (n - 1))

@@ -0,0 +1,15 @@+-- | All the definitions in these \"Internal\" modules are not version-controlled.+-- WARNING: If you depend on them, your code may break even when the nanopass package version does not increase.+--+-- They are here because I have found it useful to generate documentation for how this library works.+-- Developers can then check on how the internal interfaces are meant to work together.+--+-- * "Nanopass.Internal.Representation" defines an intermediate representation that is at the core of all operations.+-- * "Nanopass.Internal.Error" holds the data type for error reporting, and TODO will hold printers for those errors.+-- * "Nanopass.Internal.Parser" is responsible for parsing quasiquotes into language definitions, modifications, and passes.+-- * "Nanopass.Internal.Validate" is responsible for ensuring language definitions are well-formed.+-- * "Nanopass.Internal.Extend" is responsible for modifying a base language to create a new language.+-- * TODO "Nanopass.Internal.Decode" is responsible for recovering languages from Haskell data types.+-- * TODO "Nanopass.Internal.GenTypes" is responsible for generating types for a language.+-- * TODO "Nanopass.Internal.GenXlate" is responsible for generating passes (translation functions and types) between languages.+module Nanopass.Internal () where

@@ -0,0 +1,54 @@+module Nanopass.Internal.Error+  ( Error(..)+  ) where++import Nanopass.Internal.Representation (LowName,UpName,UpDotName)+import Text.SExpression (SExpr)++data Error+  = SExprError String+  -- parseLanguage+  | ExpectingLanguage SExpr+  | ExpectedLangLHS SExpr+  | ExpectedLangName String+  | ExpectingTypeVariable SExpr+  -- parseLanguageMod+  | ExpectingBaseLanguage (Maybe SExpr)+  | ExpectingKwFromAfterLHS SExpr+  | UnexpectedSExprAfterDelete SExpr+  | ExpectingPlusMinusStar SExpr+  | ExpectingNontermsEdit SExpr+  | ExpectingPlusMinus SExpr+  | ExpectingProductionsEdit SExpr+  -- parseNonterm+  | ExpectedNontermName (Maybe SExpr)+  | ExpectedNonterm SExpr+  -- parseProduction+  | ExpectedConstructorName (Maybe SExpr)+  | ExpectedProduction SExpr+  -- parseType+  | ExpectingTypeNameOrVar String+  | ExpectedTypeConstructor SExpr+  | UnexpectedLiteral SExpr+  | ConsListsDisallowed SExpr+  | UnexpectedTypeApplicationstoRecursiveType UpName+  -- validation+  | DuplicateLanguageParams [LowName]+  | UnrecognizedNonterm UpName+  | UnrecognizedTypeVariable LowName+  -- modification+  | IllegalNontermAddedAlsoDeleted UpName -- ^ nonterm was both added and deleted by a language modifier+  | IllegalNontermModificationAlsoAdded UpName -- ^ nonterm was both added and modified by a language modifier+  | IllegalNontermModificationAlsoDeleted UpName -- ^ nonterm was both modified and deleted by a language modifier+  | IllegalNontermAdded UpName -- ^ nonterminal was already present in base language+  | IllegalNontermModified UpName -- ^ nonterminal was not present in base language+  | IllegalNontermDeleted UpName -- ^ nonterminal was not present in base language+  | DuplicateNontermMods [UpName]+  | IllegalProductionAdded UpName -- ^ production was already present in base non-terminal+  | IllegalProductionDeleted UpName -- ^ production was not present in base non-terminal+  -- passes+  | MissingFromTo SExpr+  | UnexpectedSExprAfterPass UpDotName UpDotName+  | ExpectedUpDotNameAfterFrom SExpr+  | ExpectedUpDotNameAfterTo SExpr+  deriving (Show)

@@ -0,0 +1,182 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Nanopass.Internal.Extend+  ( extendLang+  , partitionNontermsEdits+  , EditingNonterms+  , addNonterms+  , modNonterms+  , delNonterms+  , extendProductions+  , partitionProductionsEdits+  ) where++import Prelude hiding (mod)+import Nanopass.Internal.Representation++import Control.Monad (forM_,when)+import Data.Functor ((<&>))+import Data.List (nub, (\\))+import Data.Map (Map)+import Data.Set (Set)+import Nanopass.Internal.Error (Error(..))+import Nanopass.Internal.Validate (validateParams,validateNonterm,validateProd)++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Language.Haskell.TH as TH++extendLang :: Language 'Valid UpDotName -> LangMod -> Either Error (Language 'Valid UpName)+extendLang orig mod = do+  let (additions, mods, deletions) = partitionNontermsEdits mod.nontermsEdit+  forM_ mods $ \(n, _) -> case (n `elem` ((.nontermName.name) <$> additions), n `elem` deletions) of+    (_, True) -> Left $ IllegalNontermModificationAlsoDeleted n+    (True, _) -> Left $ IllegalNontermModificationAlsoAdded n+    _ -> pure ()+  forM_ additions $ \add -> case add.nontermName.name `elem` deletions of+    True -> Left $ IllegalNontermAddedAlsoDeleted add.nontermName.name+    _ -> pure ()+  do+    let modNames = fst <$> mods+        duplicates = modNames \\ nub modNames+    when (not $ null duplicates) $+      Left $ DuplicateNontermMods modNames+  let modifications = Map.fromList mods+  params <- validateParams mod.newParams+  let tvs = Map.fromList $ params <&> \n -> (n.name, n)+      nts = (Set.fromList (Map.keys orig.langInfo.nonterms)+              `Set.difference` Set.fromList deletions)+            `Set.union` Set.fromList ((.nontermName.name) <$> additions)+  newNonterms <-  pure (orig.langInfo.nonterms)+              >>= delNonterms deletions+              >>= modNonterms nts tvs modifications+              >>= addNonterms nts tvs additions+  pure Language+    { langName = ValidName mod.newLang (TH.mkName $ fromUpName mod.newLang)+    , langInfo = LanguageInfo+      { langParams = params+      , nonterms = newNonterms+      , originalProgram = mod.originalModProgram+      , baseDefdLang = Just orig+      }+    }++----------------------------------+------ Nonterminals Editing ------+----------------------------------++partitionNontermsEdits :: [NontermsEdit] -> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])], [UpName])+partitionNontermsEdits = loop ([], [], [])+  where+  loop (as, ms, ds) [] = (reverse as, reverse ms, reverse ds)+  loop (as, ms, ds) (x:xs) = case x of+    AddNonterm a -> loop (a:as, ms, ds) xs+    ModNonterm n m -> loop (as, (n, m):ms, ds) xs+    DelNonterm d -> loop (as, ms, d:ds) xs++type EditingNonterms = Map UpName (Nonterm 'Valid)++addNonterms :: Set UpName -- ^ known non-terminals for the new language+            -> Map LowName (Name 'Valid LowName) -- ^ known type variables for the new language+            -> [Nonterm 'Unvalidated] -- ^ new non-terminals to add+            -> EditingNonterms -- ^ old language's non-terminals+            -> Either Error EditingNonterms+addNonterms nts tvs adds orig = loop orig adds+  where+  loop !new [] = pure new+  loop !new (add:rest) = do+    case Map.lookup add.nontermName.name new of+      Just _ -> Left $ IllegalNontermAdded add.nontermName.name+      Nothing -> pure ()+    okAdd <- validateNonterm nts tvs add+    loop (Map.insert okAdd.nontermName.name okAdd new) rest++modNonterms :: Set UpName -- ^ known non-terminals for the new language+            -> Map LowName (Name 'Valid LowName) -- ^ known type variables for the new language+            -> Map UpName [ProductionsEdit] -- ^ edits to various non-terminals' productions+            -> EditingNonterms -- ^ old language's non-terminals+            -> Either Error EditingNonterms+modNonterms nts tvs mods orig = do+  forM_ (Map.keys mods) $ \n -> case Map.lookup n orig of+    Nothing -> Left $ IllegalNontermModified n+    Just _ -> pure ()+  forWithKeyM orig $ \n oldNonterm -> case Map.lookup n mods of+    Just prodsEdit -> do+      let newName = ValidName oldNonterm.nontermName.name (TH.mkName $ fromUpName oldNonterm.nontermName.name)+      newProductions <- extendProductions nts tvs oldNonterm.productions prodsEdit+      pure $ Nonterm+        { nontermName = newName+        , productions = newProductions+        }+    Nothing -> validateNonterm nts tvs oldNonterm++delNonterms :: [UpName] -- ^ names of non-terminals to remove+            -> EditingNonterms -- ^ old language's non-terminals+            -> Either Error EditingNonterms+delNonterms dels orig = loop orig dels+  where+  loop !new [] = pure new+  loop !new (del:rest) = case Map.lookup del new of+    Just _ -> loop (Map.delete del new) rest+    Nothing -> Left $ IllegalNontermDeleted del++--------------------------------+------ Production Editing ------+--------------------------------++extendProductions :: Set UpName -- ^ known non-terminals for the new language+                  -> Map LowName (Name 'Valid LowName) -- ^ known type variables for the new language+                  -> (Map UpName (Production 'Valid))+                  -> [ProductionsEdit]+                  -> Either Error (Map UpName (Production 'Valid))+extendProductions nts tvs orig mods = do+  let (additions, deletions) = partitionProductionsEdits mods+  -- NOTE this forM_ is over-restricive because I don't have a way to modify/outright replace productions+  -- forM_ additions $ \add -> case add.prodName.name `elem` deletions of+  --   True -> Left $ IllegalProductionAddedAlsoDeleted add.prodName.name+  --   _ -> pure ()+  restricted <- delProductions deletions orig+  revalidated <- forWithKeyM restricted $ \_ oldProd ->+    validateProd nts tvs oldProd+  addProductions nts tvs additions revalidated++partitionProductionsEdits :: [ProductionsEdit] -> ([Production 'Unvalidated], [UpName])+partitionProductionsEdits = loop ([], [])+  where+  loop (as, ds) [] = (reverse as, reverse ds)+  loop (as, ds) (x:xs) = case x of+    AddProd a -> loop (a:as, ds) xs+    DelProd d -> loop (as, d:ds) xs++addProductions :: Set UpName -- ^ known non-terminals for the new language+               -> Map LowName (Name 'Valid LowName) -- ^ known type variables for the new language+               -> [Production 'Unvalidated]+               -> (Map UpName (Production 'Valid))+               -> Either Error (Map UpName (Production 'Valid))+addProductions nts tvs adds orig = loop orig adds+  where+  loop !new [] = pure new+  loop !new (add:rest) = case Map.lookup add.prodName.name new of+    Just _ -> Left $ IllegalProductionAdded add.prodName.name+    Nothing -> do+      okAdd <- validateProd nts tvs add+      loop (Map.insert okAdd.prodName.name okAdd new) rest++delProductions :: [UpName]+               -> Map UpName (Production 'Valid)+               -> Either Error (Map UpName (Production 'Valid))+delProductions dels orig = loop orig dels+  where+  loop !new [] = pure new+  loop !new (del:rest) = case Map.lookup del new of+    Just _ -> loop (Map.delete del new) rest+    Nothing -> Left $ IllegalProductionDeleted del++---------------------+------ Helpers ------+---------------------++forWithKeyM :: (Ord k, Applicative f) => Map k a -> (k -> a -> f b) -> f (Map k b)+forWithKeyM m f = sequenceA $ Map.mapWithKey f m

@@ -0,0 +1,421 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}++-- | This module contains functions that translate Haskell quasiquotes into+-- internal representations of languages and passes as defined in "Nanopass.Internal.Representation".+-- This is done by first parsing an s-expression with "Text.SExpression",+-- and then recursively recognizing the components of that s-expression.+--+-- The primary entry points are 'parseLanguage' and TODO 'parsePass`.+-- Other recognizers are exported to serve as the promary source for+-- documentation about the grammar used in these quasiquotes.+module Nanopass.Internal.Parser+  (+  -- * Recognizers+    ParseResult+  , parseLanguage+  -- ** Base Languages+  , parseBaseLanguage+  , parseNonterm+  , parseProduction+  -- ** Language Modification+  , parseLangMod+  , parseNontermsEdit+  , parseProductionsEdit+  -- ** Shared Recognizers+  , parseLangLHS+  , parseNontermBody+  , parseProductionBody+  , parseType+  -- * Passes+  , parsePass+  -- * S-Expressions+  , getSexpr+  , Loc(..)+  , toUpColonName+  ) where++import Nanopass.Internal.Representation++import Control.Monad (forM)+import Data.Functor ((<&>))+import Nanopass.Internal.Error (Error(..))+import Text.Megaparsec (runParser',State(..),PosState(..),SourcePos(..),errorBundlePretty)+import Text.Megaparsec.Char (space1)+import Text.Megaparsec.Pos (defaultTabWidth,mkPos)+import Text.SExpression (SExpr(..),Parser,parseSExpr,def)++import qualified Data.Map as Map+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char.Lexer as P++------------------------------+------ Glue it together ------+------------------------------++type ParseResult = Either+  (Language 'Unvalidated UpName)  -- ^ base language defintion+  LangMod -- ^ modifications to a language++-- | @+-- Language ::= \<BaseLang\> | \<LangMod\>+-- @+--+-- * for @BaseLang@, see 'parseBaseLanguage'+-- * for @LangMod@, see 'parseLangMod'+parseLanguage :: (Loc, String) -> Either Error ParseResult+parseLanguage inp@(_, orig) = do+  sexpr <- getSexpr inp+  case sexpr of+    List (_:Atom "from":_) -> Right <$> parseLangMod orig sexpr+    _ -> Left <$> parseBaseLanguage orig sexpr++---------------------------------+------ Recognize Languages ------+---------------------------------++-- | @+-- BaseLang ::=+--   (\<LangLHS\>        language name and type variables+--       \<string…\>     documentation+--       \<Nonterm…\>)   syntactic categories+-- @+--+-- * for @LangLHS@, see 'parseLangLHS'+-- * for @Nonterm@, see 'parseNonterm'+parseBaseLanguage :: String -> SExpr -> Either Error (Language 'Unvalidated UpName)+parseBaseLanguage originalProgram (List (lhs:rest)) = do+  (name, langParams) <- parseLangLHS lhs+  let langName = SourceName name+      (docs, nonterms_) = spanDocstrs rest+  nontermList <- parseNonterm `mapM` nonterms_+  let nonterms = Map.fromList $ nontermList <&> \s -> (s.nontermName.name, s)+  pure Language+    { langName+    , langInfo = LanguageInfo+      { langParams = SourceName <$> langParams+      , nonterms+      , originalProgram = Just originalProgram+      , baseDefdLang = Nothing+      }+    }+parseBaseLanguage _ other = Left $ ExpectingLanguage other++-- | @+-- LangLHS ::= \<UpCase\>                 language name, zero type variables+--          |  (\<UpCase\> \<LowCase…\>)    language name, type variables+-- @+--+-- * for @UpCase@, see 'toUpName'+-- * for @LowCase@, see 'toLowName'+parseLangLHS :: SExpr -> Either Error (UpName, [LowName])+parseLangLHS (Atom str) = case toUpName str of+  Just name -> pure (name, [])+  Nothing -> Left $ ExpectedLangName str+parseLangLHS (List (Atom str:rest)) = do+  name <- case toUpName str of+    Just name -> pure name+    Nothing -> Left $ ExpectedLangName str+  tyVars <- forM rest $ \case+    Atom tvStr | Just tvName <- toLowName tvStr -> pure tvName+    it -> Left $ ExpectingTypeVariable it+  pure (name, tyVars)+parseLangLHS it = Left $ ExpectedLangLHS it++-- | @+-- Nonterm ::=+--   (\<UpCase\>             type name+--       \<string…\>         documentation+--       \<Production…\>)    constructor arguments+-- @+--+-- * for @UpCase@, see 'toUpName'+-- * for @Production@, see 'parseProduction'+parseNonterm :: SExpr -> Either Error (Nonterm 'Unvalidated)+parseNonterm (List (Atom str:rest)) = do+  nontermName <- case toUpName str of+    Just name -> pure name+    Nothing -> Left $ ExpectedNontermName (Just $ Atom str)+  parseNontermBody nontermName rest+parseNonterm (List (other:_)) = Left $ ExpectedNontermName (Just other)+parseNonterm other = Left $ ExpectedNonterm other++-- | Separated out from 'parseNonterm' because it is useful in 'parseNontermsEdit' as well.+parseNontermBody :: UpName -> [SExpr] -> Either Error (Nonterm 'Unvalidated)+parseNontermBody nontermName rest = do+  let (docs, prods_) = spanDocstrs rest+  productionList <- parseProduction `mapM` prods_+  let productions = Map.fromList $ productionList <&> \p -> (p.prodName.name, p)+  pure Nonterm+    { nontermName = SourceName nontermName+    , productions+    }++-- | @+-- Production ::=+--   (\<UpCase\>        constructor name+--       \<string…\>    documentation+--       \<Type…\>)     constructor arguments+-- @+--+-- * for @UpCase@, see 'toUpName'+-- * for @Type@, see 'parseType'+parseProduction :: SExpr -> Either Error (Production 'Unvalidated)+parseProduction (List (Atom ctorStr:rest)) = do+  prodName <- case toUpName ctorStr of+    Just name -> pure name+    Nothing -> Left $ ExpectedConstructorName (Just $ Atom ctorStr)+  parseProductionBody prodName rest+parseProduction other = Left $ ExpectedProduction other++-- | Separated out from 'parseProduction' because it is useful in 'parseProductionsEdit' as well.+parseProductionBody :: UpName -> [SExpr] -> Either Error (Production 'Unvalidated)+parseProductionBody prodName rest = do+  let (docs, args) = spanDocstrs rest+  subterms <- parseType `mapM` args+  pure Production+    { prodName = SourceName prodName+    , subterms+    }++-- | @+-- Type ::= \<lowCase name\>                 type parameter+--       |  \<UpColonName\>                  plain Haskell type (kind *)+--                                         or non-terminal (language parameters already applied)+--       |  (\<UpColonName\> \<Type…\>)        plain Haskell type application+--       |  (\'?\' \<Type\>)                   Maybe type+--       |  (\'*\' \<Type\>)                   List type+--       |  (\'+\' \<Type\>)                   NonEmpty type+--       |  () | (\'&\')                     unit type+--       |  (\'&\' \<Type\>)                   Only type TODO+--       |  (\'&\' \<Type\> \<Type\> \<Type…\>)    tuple types+-- @+--+--+-- * for @UpCase@, see 'toUpName'+-- * for @LowCase@, see 'toLowName'+-- * for @UpColonCase@, see 'toUpColonName'+parseType :: SExpr -> Either Error (TypeDesc 'Unvalidated)+parseType = \case+  Atom str+    | Just name <- toUpColonName str+      -> pure $ CtorType (SourceName name) []+    | Just name <- toLowName str+      -> pure $ VarType (SourceName name)+    | otherwise -> Left $ ExpectingTypeNameOrVar str+  List [] -> pure UnitType+  List [Atom "?", x] -> MaybeType <$> parseType x+  List [Atom "*", x] -> ListType <$> parseType x+  List [Atom "+", x] -> NonEmptyType <$> parseType x+  List (Atom "&" : xs_) -> case xs_ of+    [] -> pure UnitType+    [x] -> parseType x -- TODO Data.Tuple.Only+    (x1:x2:xs) -> do+      t1 <- parseType x1+      t2 <- parseType x2+      ts <- parseType `mapM` xs+      pure $ TupleType t1 t2 ts+  List (x:xs) -> do+    ctor <- case x of+      Atom str | Just name <- toUpColonName str -> pure name+      _ -> Left $ ExpectedTypeConstructor x+    ts <- parseType `mapM` xs+    pure $ CtorType (SourceName ctor) ts+  x@(ConsList _ _) -> Left $ ConsListsDisallowed x+  x@(Number _) -> Left $ UnexpectedLiteral x+  x@(String _) -> Left $ UnexpectedLiteral x+  x@(Bool _) -> Left $ UnexpectedLiteral x++spanDocstrs :: [SExpr] -> ([String], [SExpr])+spanDocstrs = loop []+  where+  loop acc (String str:rest) = loop (str:acc) rest+  loop acc rest = (reverse acc, rest)++-----------------------------------+------ Language Modification ------+-----------------------------------++-- | @+-- LangMod ::=+--   (\<LangLHS\>             new language name and type variables+--         \'from\'           keyword+--         \<UpColon\>        base language name+--       \<string…\>          documentation+--       \<NontermsEdit…\>)   changes to the base language's syntactic categories+-- @+--+-- * for @LangLHS@, see 'parseLangLHS'+-- * for @UpColon@, see 'toUpColonName'+-- * for @NontermsEdit@, see 'parseNontermsEdit'+parseLangMod :: String -> SExpr -> Either Error LangMod+parseLangMod originalModProgram (List (lhs:Atom "from":rest_)) = do+  (newLang, newParams) <- parseLangLHS lhs+  (baseLang, rest) <- case rest_ of+    (Atom str):rest | Just name <- toUpColonName str -> pure (name, rest)+    other:_ -> Left $ ExpectingBaseLanguage (Just other)+    _ -> Left $ ExpectingBaseLanguage Nothing+  let (docs, edits_) = spanDocstrs rest+  edits <- parseNontermsEdit `mapM` edits_+  pure LangMod+    { baseLang+    , newLang+    , newParams = SourceName <$> newParams+    , nontermsEdit = edits+    , originalModProgram = Just originalModProgram+    }+parseLangMod _ other = Left $ ExpectingKwFromAfterLHS other++-- | @+-- NontermsEdit+--   ::= (\'+\'                       add a syntactic category+--           \<UpCase\>                 new non-terminal name+--           \<string…\>                documentation+--           \<Production…\>)           constructors+--    |  (\'-\' \<UpCase\>)             remove a syntactic category by name+--    |  (\'*\'                       modify a syntactic category's productions+--           \<UpCase name\>            name of non-terminal to edit+--           \<ProductionsEdit…\>)      changes to the base language's non-terminal+-- @+--+-- * for @UpCase@, see 'toUpName'+-- * for @Production@, see 'parseProduction'+-- * for @ProductionsEdit@, see 'parseProductionsEdit'+parseNontermsEdit :: SExpr -> Either Error NontermsEdit+parseNontermsEdit (List (Atom "+":rest_)) = do+  (nontermName, rest) <- case rest_ of+    (Atom str):rest | Just name <- toUpName str -> pure (name, rest)+    other:_ -> Left $ ExpectedNontermName (Just other)+    [] -> Left $ ExpectedNontermName Nothing+  nonterm <- parseNontermBody nontermName rest+  pure $ AddNonterm nonterm+parseNontermsEdit (List (Atom "-":rest_)) = do+  (nontermName, rest) <- case rest_ of+    (Atom str):rest | Just name <- toUpName str -> pure (name, rest)+    other:_ -> Left $ ExpectedNontermName (Just other)+    [] -> Left $ ExpectedNontermName Nothing+  case rest of+    [] -> pure ()+    x:_ -> Left $ UnexpectedSExprAfterDelete x+  pure $ DelNonterm nontermName+parseNontermsEdit (List (Atom "*":rest_)) = do+  (nontermName, rest) <- case rest_ of+    (Atom str):rest | Just name <- toUpName str -> pure (name, rest)+    other:_ -> Left $ ExpectedNontermName (Just other)+    [] -> Left $ ExpectedNontermName Nothing+  edits <- parseProductionsEdit `mapM` rest+  pure $ ModNonterm nontermName edits+parseNontermsEdit (List (other:_)) = Left $ ExpectingPlusMinusStar other+parseNontermsEdit other = Left $ ExpectingNontermsEdit other++-- | @+-- ProductionsEdit+--   ::= (\'+\'              add a production+--           \<UpCase\>        new constructor name+--           \<string…\>       documentation+--           \<Type…\>)        constructor arguments+--    |  (\'-\' \<UpCase\>)    remove a production by name+-- @+--+-- * for @UpCase@, see 'toUpName'+-- * for @Type@, see 'parseType'+parseProductionsEdit :: SExpr -> Either Error ProductionsEdit+parseProductionsEdit (List (Atom "+":rest_)) = do+  (prodName, rest) <- case rest_ of+    (Atom str):rest | Just name <- toUpName str -> pure (name, rest)+    other:_ -> Left $ ExpectedConstructorName (Just other)+    [] -> Left $ ExpectedConstructorName Nothing+  prod <- parseProductionBody prodName rest+  pure $ AddProd prod+parseProductionsEdit (List (Atom "-":rest_)) = do+  (prodName, rest) <- case rest_ of+    (Atom str):rest | Just name <- toUpName str -> pure (name, rest)+    other:_ -> Left $ ExpectedConstructorName (Just other)+    [] -> Left $ ExpectedConstructorName Nothing+  case rest of+    [] -> pure ()+    x:_ -> Left $ UnexpectedSExprAfterDelete x+  pure $ DelProd prodName+parseProductionsEdit (List (other:_)) = Left $ ExpectingPlusMinus other+parseProductionsEdit other = Left $ ExpectingProductionsEdit other++---------------------------------+------ Parse S-Expressions ------+---------------------------------++-- | This is a location type that should be sufficient to describe the start of a Template Haskell quasiquote.+-- It is used in 'getSexpr' so that it can report errors from the actual source code location.+data Loc = Loc+  { file :: FilePath+  , line :: Int+  , col :: Int+  }++-- | This serves as an adapter between Template Haskell and whatever s-expression parser I decide to use.+getSexpr :: (Loc, String) -> Either Error SExpr+getSexpr (loc, inp) = case runParser' (sc *> parseSExpr def <* sc) state0 of+    (_, Left err) -> Left . SExprError $ errorBundlePretty err+    (_, Right sexpr) -> Right sexpr+  where+  sc :: Parser ()+  sc = P.space space1 (P.skipLineComment ";") P.empty+  state0 = State+    { stateInput = inp+    , stateOffset = 0+    , statePosState = PosState+      { pstateInput = inp+      , pstateOffset = 0+      , pstateSourcePos = SourcePos+        { sourceName = loc.file+        , sourceLine = mkPos loc.line+        , sourceColumn = mkPos loc.col+        }+      , pstateTabWidth = defaultTabWidth+      , pstateLinePrefix = ""+      }+    , stateParseErrors = []+    }++-- | Since sexprs don't allow dot in names, we use colon instead.+-- We just immediately translate it over into dots.+--+-- That is, accept strings matching @[A-Z][a-zA-Z0-9_]\(:[A-Z][a-zA-Z0-9_])*@,+-- and alter them with @s\/\\.\/:\/@.+toUpColonName :: String -> Maybe UpDotName+toUpColonName = toUpDotName . map (\c -> if c == ':' then '.' else c)++--------------------------+------ Parse Passes ------+--------------------------+++-- | @+-- Pass+--   ::= (\'from\' \<UpColonCase\>    source lagnuage name+--        \'to\' \<UpColonCase\>      target lagnuage name+--          \<string…\>               documentation+-- @+--+-- * for @UpColonCase@, see 'toUpColonName'+parsePass :: (Loc, String) -> Either Error Pass+parsePass inp = parsePassSexpr =<< getSexpr inp++parsePassSexpr :: SExpr -> Either Error Pass+parsePassSexpr (List (Atom"from":l1:Atom "to":l2:rest)) = do+  sourceLang <- case l1 of+    Atom str | Just name <- toUpColonName str -> pure $ SourceName name+    _ -> Left $ ExpectedUpDotNameAfterFrom l1+  targetLang <- case l2 of+    Atom str | Just name <- toUpColonName str -> pure $ SourceName name+    _ -> Left $ ExpectedUpDotNameAfterTo l2+  let (docs, after) = spanDocstrs rest+  case after of+    [] -> pure ()+    _ -> Left $ UnexpectedSExprAfterPass sourceLang.name targetLang.name+  pure Pass+    { sourceLang+    , targetLang+    }+parsePassSexpr other = Left $ MissingFromTo other

@@ -0,0 +1,239 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | This module holds type definitions that describe the internal+-- representation of language syntaxen as understood by nanopass.+module Nanopass.Internal.Representation+  (+  -- * Types for Base Languages+  -- $ir+    Language(..)+  , LanguageInfo(..)+  , Nonterm(..)+  , Production(..)+  , TypeDesc(..)+  -- * Types for Modifying Manguages+  , LangMod(..)+  , NontermsEdit(..)+  , ProductionsEdit(..)+  -- * Types for Passes+  , Pass(..)+  -- * Helper Types+  , UpName, toUpName, fromUpName+  , LowName, toLowName, fromLowName+  , UpDotName, toUpDotName, fromUpDotName, splitUpDotName+  , unDotted, upDotQualifier, upDotBase, upDotChBase+  , Name(..), Validate(..)+  ) where++import Data.Char (isLower,isUpper,isAlphaNum)+import Data.List (intercalate)+import Data.Map (Map)+import GHC.Records (HasField(..))++import qualified Language.Haskell.TH as TH++------ Names ------++-- | Strings matching @[A-Z][a-zA-Z0-9_]@+newtype UpName = UpName String+  deriving (Show,Eq,Ord)++-- | Introduction form for 'UpName'+toUpName :: String -> Maybe UpName+toUpName (c:cs) | isUpper c && all isAlphaNum cs = Just $ UpName (c:cs)+toUpName _ = Nothing++-- | Elimination form for 'UpName'+fromUpName :: UpName -> String+fromUpName (UpName str) = str++-- | Strings matching @[a-z][a-zA-Z0-9_]@+newtype LowName = LowName String+  deriving (Show,Eq,Ord)++-- | Introduction form for 'LowName'+toLowName :: String -> Maybe LowName+toLowName (c:cs) | isLower c && all isAlphaNum cs = Just $ LowName (c:cs)+toLowName _ = Nothing++-- | Elimination form for 'LowName'+fromLowName :: LowName -> String+fromLowName (LowName str) = str++-- | Strings matching @[A-Z][a-zA-Z0-9_]\(:[A-Z][a-zA-Z0-9_])*@+data UpDotName = UpDotName [UpName] UpName+  deriving (Show,Eq,Ord)++-- | Introduction form for 'UpDotName'+toUpDotName :: String -> Maybe UpDotName+toUpDotName = loop []+  where+  loop acc inp = case break (== '.') inp of+    ([], _) -> Nothing -- no leading dot, double dot, or empty string allowed+    (_, ".") -> Nothing -- no trailing dot allowed+    (str, []) -> do -- no more dots+      endName <- toUpName str+      pure $ UpDotName (reverse acc) endName+    (str, _:rest) -> do+      qual <- toUpName str+      loop (qual:acc) rest++-- | Elimination form for 'UpDotName'+fromUpDotName :: UpDotName -> String+fromUpDotName (UpDotName strs str) = intercalate "." $ fromUpName <$> (strs ++ [str])++-- | Conversion from 'UpName'+unDotted :: UpName -> UpDotName+unDotted x = UpDotName [] x++-- | Get the parts of a dotted name that come before the last dot+upDotQualifier :: UpDotName -> [UpName]+upDotQualifier (UpDotName xs _) = xs++-- | Get the last part of a dotted name+upDotBase :: UpDotName -> UpName+upDotBase (UpDotName _ x) = x++-- | Create a dotted name identical to the first, but with the last part replaced+upDotChBase :: UpDotName -> UpName -> UpDotName+upDotChBase (UpDotName xs _) y = UpDotName xs y++-- | Get the last part of a dotted name and it's prefix+splitUpDotName :: UpDotName -> ([UpName], UpName)+splitUpDotName (UpDotName xs x) = (xs, x)++data Validate = Valid | Unvalidated+data Name v n where+  SourceName :: { name_ :: n } -> Name 'Unvalidated n+  ValidName :: { base_ :: n, th :: TH.Name } -> Name 'Valid n+deriving instance (Show n) => Show (Name v n)+deriving instance (Eq n) => Eq (Name v n)+deriving instance (Ord n) => Ord (Name v n)++instance HasField "name" (Name v n) n where+  getField (SourceName n) = n+  getField (ValidName n _) = n++----------------------------+------ Base Languages ------+----------------------------++-- $ir+--+-- The types 'Language', 'Nonterm', 'Production' mediate between Haskell and the theory of context-free grammars (CFGs).+-- Each of them is an intermediate representation that can be seen from two perspectives:+--+-- * What Haskell concept do they map to?+-- * What CFG concept do they map to?+--+-- We use something like usual, minimal definition of a CFG as a 4-tuple G = (V, Σ, R, S) where+--+-- 1. V is a set of non-terminals (named by 'nontermName')+-- 2. Σ is a set of terminals (which are just ordinary Haskell data types)+-- 3. R is a relation in V × (V ∪ Σ)*. Members of this relation are called rewrite rules (and map to the arguments of a Haskell data constructor).+-- 4. S is the start symbol, though it is not used by nanopass.++-- | This attributes a name to a set of grammatical types.+-- Languages can have different names in different contexts;+-- importantly, they must not be qualified when defining, but they may need to be dotted when referring to a language from another module.+data Language v n = Language+  { langName :: Name v n+  , langInfo :: LanguageInfo v+  }+  deriving(Show)++-- | Seen as a Haskell entity, each 'Language' is a set of mutually-recursive types.+-- Seen from the persepctive of a CFG, each of these types is a non-terminal used to define the abstract grammar of a language.+--+-- See 'Language' for attributing a name to a set of these types.+data LanguageInfo v = LanguageInfo+  { langParams :: ![Name v LowName]+  -- ^ type parameters; these apply to each of the 'Nonterm' types+  , nonterms :: !(Map UpName (Nonterm v)) -- TODO make this a list+  , originalProgram :: !(Maybe String)+  , baseDefdLang :: !(Maybe (Language 'Valid UpDotName))+  }+  deriving(Show)++-- | Seen as a Haskell entity, each 'Nonterm' is a single type with some number of constructors.+-- Seem from the perspective of a CFG, each 'Nonterm' is… well, a non-terminal symbol.+--+-- 'Nonterm's are the primary constituent of a 'Language'.+data Nonterm v = Nonterm+  { nontermName :: !(Name v UpName)+  , productions :: !(Map UpName (Production v))+  }+  deriving(Show)++-- | Seen as a Haskell entity, each 'Production' maps to a constructor for a 'Nonterm' data type.+-- Seen from the perspective of a CFG, each 'Production' maps to a single rewrite rule.+--+-- 'Production's are the primary constituent of 'Nonterm's.+data Production v = Production+  { prodName :: !(Name v UpName)+  , subterms :: ![TypeDesc v]+  }+  deriving(Show)++-- | Seen as a Haskell entity, a 'TypeDesc' gives the type of an argument of a constructor ('Production').+-- Seen from the perspective of a CFG, each 'TypeDesc' is a symbol (terminal or non-terminal) on the right-hand side of a rewrite rule.+--+-- 'TypeDesc's are the primary constituent of 'Production's.+data TypeDesc v+  = RecursiveType UpName+  -- ^ a non-terminal symbol/recursive use of a 'Nonterm' type+  --+  -- These types need not be applied to any arguments, the language 'langParams' get auromatically applied.+  | VarType (Name v LowName)+  -- ^ allows the use of 'langParams' as terminal symbols+  | CtorType (Name v UpDotName) [TypeDesc v]+  -- ^ allows the use of plain (not defined by nanopass) Haskell types,+  -- either as terminal symbols, or as combinators over non-terminal and terminal symbols+  | ListType (TypeDesc v) -- because otherwise, you'd have to always be saying `type List a = [a]`+  -- ^ nanopass has built-in knowledge of lists, so they are represented specially as opposed to with 'CtorType'+  | MaybeType (TypeDesc v)+  -- ^ nanopass has built-in knowledge of optionals, so they are represented specially as opposed to with 'CtorType'+  | NonEmptyType (TypeDesc v)+  -- ^ nanopass has built-in knowledge of non-empty lists, so they are represented specially as opposed to with 'CtorType'+  | UnitType+  -- ^ nanopass has built-in knowledge of the unit type, so they are represented specially as opposed to with 'CtorType'+  | TupleType (TypeDesc v) (TypeDesc v) [TypeDesc v]+  -- ^ nanopass has built-in knowledge of the tuple types, so they are represented specially as opposed to with 'CtorType'+  deriving(Eq,Show)++---------------------------------+------ Modifying Languages ------+---------------------------------++data LangMod = LangMod+  { baseLang :: UpDotName+  , newLang :: UpName+  , newParams :: [Name 'Unvalidated LowName]+  , nontermsEdit :: [NontermsEdit]+  , originalModProgram :: Maybe String+  }+  deriving(Show)++data NontermsEdit+  = AddNonterm (Nonterm 'Unvalidated)+  | ModNonterm UpName [ProductionsEdit]+  | DelNonterm UpName+  deriving(Show)++data ProductionsEdit+  = AddProd (Production 'Unvalidated)+  | DelProd UpName+  deriving(Show)++--------------------+------ Passes ------+--------------------++data Pass = Pass+  { sourceLang :: Name 'Unvalidated UpDotName+  , targetLang :: Name 'Unvalidated UpDotName+  }+  deriving (Show)

@@ -0,0 +1,101 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Nanopass.Internal.Validate+  ( validateLanguage+  , validateParams+  , validateNonterm+  , validateProd+  , validateType+  ) where++import Nanopass.Internal.Representation++import Control.Monad (forM,when)+import Data.Functor ((<&>))+import Data.List (nub, (\\))+import Data.Map (Map)+import Data.Set (Set)+import Nanopass.Internal.Error (Error(..))++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Language.Haskell.TH as TH++validateLanguage :: Language 'Unvalidated UpName -> Either Error (Language 'Valid UpName)+validateLanguage lang = do+  langParams <- validateParams lang.langInfo.langParams+  let tvs = Map.fromList $ langParams <&> \n -> (n.name, n)+      nts = Set.fromList $ Map.keys lang.langInfo.nonterms+  nonterms <- validateNonterm nts tvs `mapM` lang.langInfo.nonterms+  pure Language+    { langName = ValidName lang.langName.name (TH.mkName $ fromUpName lang.langName.name)+    , langInfo = LanguageInfo+      { langParams+      , nonterms+      , originalProgram = lang.langInfo.originalProgram+      , baseDefdLang = lang.langInfo.baseDefdLang+      }+    }++validateParams :: [Name 'Unvalidated LowName] -> Either Error [Name 'Valid LowName]+validateParams tvs = do+  let duplicates = tvs \\ nub tvs+  when (not $ null duplicates) $ Left $ DuplicateLanguageParams (duplicates <&> (.name))+  forM tvs $ \n -> pure $ ValidName n.name (TH.mkName $ fromLowName n.name)++validateNonterm :: Set UpName -- ^ known non-terminals+                -> Map LowName (Name 'Valid LowName) -- ^ known type variables+                -> Nonterm v+                -> Either Error (Nonterm 'Valid)+validateNonterm nts tvs nt = do+  let nontermName = ValidName nt.nontermName.name (TH.mkName $ fromUpName nt.nontermName.name)+  productions <- validateProd nts tvs `mapM` nt.productions+  pure Nonterm+    { nontermName+    , productions+    }++validateProd :: Set UpName -- ^ known non-terminals+             -> Map LowName (Name 'Valid LowName) -- ^ known type variables+             -> Production v+             -> Either Error (Production 'Valid)+validateProd nts tvs prod = do+  let prodName = ValidName prod.prodName.name (TH.mkName $ fromUpName prod.prodName.name)+  subterms <- validateType nts tvs `mapM` prod.subterms+  pure Production+    { prodName+    , subterms+    }++validateType :: Set UpName -- ^ known non-terminals+             -> Map LowName (Name 'Valid LowName) -- ^ known type variables+             -> TypeDesc v+             -> Either Error (TypeDesc 'Valid)+validateType nts tvs = \case+  RecursiveType n -> case Set.member n nts of+    True -> pure $ RecursiveType n+    False -> Left $ UnrecognizedNonterm n+  VarType n -> case Map.lookup n.name tvs of+    Just validName -> pure $ VarType validName+    Nothing -> Left $ UnrecognizedTypeVariable n.name+  CtorType n ts+    | ([], n') <- splitUpDotName n.name+    , n' `Set.member` nts+    -> case ts of+      [] -> pure $ RecursiveType n'+      _ -> Left $ UnexpectedTypeApplicationstoRecursiveType n'+  CtorType (SourceName n) ts -> do+    let ctor = ValidName n (TH.mkName $ fromUpDotName n)+    CtorType ctor <$> loop `mapM` ts+  CtorType ctor@(ValidName _ _) ts -> do+    CtorType ctor <$> loop `mapM` ts+  ListType t -> ListType <$> loop t+  MaybeType t -> MaybeType <$> loop t+  NonEmptyType t -> NonEmptyType <$> loop t+  UnitType -> pure UnitType+  TupleType t1 t2 ts -> TupleType <$> loop t1 <*> loop t2 <*> loop `mapM` ts+  where loop = validateType nts tvs

@@ -1,69 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Text.Parse.Stupid-  ( Sexpr(..)-  , parse-  , hydrateSpaces-  , print-  ) where--import Prelude hiding (print)--import Data.Bifunctor (first)--data Sexpr a = Atom a | Combo String [Sexpr a]-  deriving (Eq, Ord, Show, Read, Functor)--brackPairs :: [(String, String)]-brackPairs =-  [ ( "("  , ")" )-  , ( "$(" , ")" )-  , ( "["  , "]" )-  , ( "{"  , "}" )-  ]--parse :: String -> Maybe [Sexpr String]-parse = fmap fst . go . tokenize-  where-  go :: [String] -> Maybe ([Sexpr String], [String])-  go [] = Just ([], [])-  go (t:ts) = case t of-    close | close `elem` fmap snd brackPairs -> Just ([], t:ts)-    open | Just close <- lookup open brackPairs -> do-      (inner, rest) <- go ts-      case rest of-        t':rest' | t' == close -> (fmap . first) (Combo open inner :) (go rest')-        _ -> Nothing-    _ -> (fmap . first) (Atom t:) (go ts)--tokenize :: String -> [String]-tokenize input = do-  line <- lines input-  case line of-    '#':_ -> [] -- remove comment lines-    _ -> do-      word <- words line-      unbracket word--unbracket :: String -> [String]-unbracket = filter (not . null) . loop ""-  where-  loop acc "" = [reverse acc]-  loop acc ('$':'(':cs) = reverse acc : "$(" : loop "" cs-  loop acc (c:cs)-    | c `elem` "()[]{}" = reverse acc : [c] : loop "" cs-    | otherwise = loop (c:acc) cs--hydrateSpaces :: String -> String-hydrateSpaces ('\"':content) = go content-  where-  go [] = []-  go ('\\':'\\':rest) = '\\':'\\':go rest-  go ('\\':'+':rest) = ' ':go rest-  go (c:rest) = c:go rest-hydrateSpaces str = str--print :: (a -> String) -> Sexpr a -> String-print f (Atom a) = f a-print f (Combo open sexprs) = case lookup open brackPairs of-  Just close -> open ++ unwords (print f <$> sexprs) ++ close-  Nothing -> errorWithoutStackTrace $ "Text.Parse.Stupid.print: not an open bracket " ++ show open