nanopass (empty) → 0.0.2.0
raw patch · 11 files changed
+1936/−0 lines, 11 filesdep +basedep +containersdep +mtl
Dependencies added: base, containers, mtl, nanopass, pretty-simple, template-haskell, transformers
Files
- CHANGELOG.md +14/−0
- LICENSE +30/−0
- README.md +288/−0
- app/Lang.hs +30/−0
- app/Main.hs +48/−0
- nanopass.cabal +52/−0
- src/Language/Nanopass.hs +11/−0
- src/Language/Nanopass/LangDef.hs +501/−0
- src/Language/Nanopass/QQ.hs +412/−0
- src/Language/Nanopass/Xlate.hs +481/−0
- src/Text/Parse/Stupid.hs +69/−0
+ CHANGELOG.md view
@@ -0,0 +1,14 @@+# Revision history for nanopass++## 0.0.2.0 -- YYYY-mm-dd++* Generate documentation for the members of `Xlate` and `XlateI`.+* Add generation of pure variants of translation facilities to `defpass`.+* Change `{Xlate,descend*}A` names to drop the `A`; applicative is probably the more common case.+* Fix bug in testing for `Traversable` instance.+* Generate documentation for generated types/functions.+* Requires template-haskell >=2.18, and therefore GHC 9.2.1++## 0.0.1.0 -- 2022-01-26++* First version. Unreleased in any unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Eric Demko (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Eric Demko nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,288 @@+# 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.+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+ * create automatic translations between those languages,+ 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).++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).++I have envied Nanopass for its elegance, but didn't want to give up static typing for it.+Not anymore!+Today, I actually know enough Template Haskell that it has become possible for me to port Nanopass into Haskell, and that is what this is.++## A Small Example++Let's say we find an academic paper that describes the syntax of a simple lambda calculus:+```+e ::= x+ | λx. e+ | e₁ e₂+```+Then the author goes on to describe let-binding as syntactic sugar.+They make the relevant changes to the grammar:+```+e ::= …+ | 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ₓ+```++Why can't we do this in Haskell?+The main problem is that the author is abusing notation:+ when the syntax looks the same in λₗₑₜ as it does in λ, they just let the reader imagine the injections from one to the other.+Haskell compilers, as smart as they are, are (thankfully?) not smart enough to have human intuition and a sense of the "obvious".+That's why we need to write a bunch of boilerplate… or have Template Haskell write it for us!+Observe the close correspondence of the following Haskell code with the informal mathematics from before.++First, we will define a syntax language of λ.+```+{-# LANGUAGE QuasiQuotes #-}+module Lambda where+import Data.Language.Nanopass (deflang)++[deflang| Lambda+(Expr+ ( Var String )+ ( Lam {x String} {body $Expr} )+ ( App {f $Expr} {a $Expr} )+)+|]+```++Then, in a separate module, we will define λₗₑₜ by modifying our existing λ implementation.+It's best to put each language in its own module.+For one thing, for Nanopass to be useful, many constructor and field names are shared between languages.+On the other, Haskell's compile times are super-linear in the size of a module but (barring full-program optimization) linear in the number of modules; since Template Haskell can generate lots of code, it's broadly good to keep its usage contained.++```+module LambdaLet where+import Data.Language.Nanopass (deflang, defpass)+import Data.Functor.Identity (Identity(runIdentity))+import Data.List (foldl1)++import qualified Lambda as L0++[deflang|L0.Lambda :-> LambdaLet+(* Expr+ (+ Let {bind ({String $Expr} +)} {letIn $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 no-op splice separates the two quasiquotes so that the definitions of the+-- first are available to the second. Declaration order can be finicky, and+-- hopefully I can get rid of this requirement, but for now I've pointed it out+-- because I expect it to be a pitfall for people not familiar with TH. Of course,+-- this is not needed if your pass is defined in a separate module from the+-- language definition.+$(pure [])++[defpass|LambdaLet :-> Lambda|]++compile :: L0.Expr -> Expr+compile = runIdentity . descendExprA 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+ { exprLet = \bind body -> pure $ foldr unlet body bind+ -- the `expr` member allows us to optionally override the default translation when necessary+ , expr = const Nothing -- we don't need to override anything+ }+ unlet body (x, e) = (Lam x body) `App` e+```++Thankfully, we didn't need to write any code to translate the `Var`, `App`, or `Lam` constructors:+ we could focus on just the important part, which was the `Let` constructor of `Expr`.+Now consider the code savings that such an approach could provide for+ a language with a hundred or more data constructors+ spread across several mutually-recursive types, and which+ must make its way through dozens of passes!++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.+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++The example above only examined a portion of this implementation's capabilities.+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.+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.++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.++It is best to define each language in a separate module.+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).+If the only thing you define in a module is a language, then it's easy enough to just export everything.++### Translations++You can request Nanopass to generate automatic translation between two languages.+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.+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>`.+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+ `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 source language has syntactic category `σ` with the same name as the target's syntactic category `σ'`,+ 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`.++We also generate a pure variant of the functor-based translations.+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`.+ 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.+ Under the hood, this is done with appropriate wrapping/unwrapping of `Identity`, which is a no-op.++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 knows about `Traversable`:+ if the only mention of a syntactic category 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.+++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.++### 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++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 for defining languages, from scratch or by derivation is:+```+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⟩++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++type operator+ ::= * # []+ | + # NonEmpty+ | ? # Maybe++syntactic category modifier+ ::= ( + ⟨syntactic category⟩… ) # add+ | ( - ⟨UpName⟩… ) # remove+ | ( * ⟨production modifier⟩… ) # modify+production modifier+ ::= ( + ⟨UpName⟩ ⟨subterm⟩… )+ | ( - ⟨Upname⟩ )+```++The syntax for requesting a translation is:+```+⟨Up.Name⟩ :-> ⟨Up.Name⟩+```++### What are "Syntactic Categories"?++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.++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.++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.)++\*Some other theories dispense entirely with the concept of a phrase, making use of the term moot.++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.
+ app/Lang.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}++module Lang where++import Data.Monoid (First)+import Language.Nanopass (deflang)++data Foo a b c = Foo [c]+ deriving (Show,Functor,Foldable,Traversable)++[deflang| L0 (funny)+ (Expr+ (Var {x String})+ (Lam {x String} {e ($Stmt *)})+ (App {f $Expr} {a $Expr})+ (Nope String)+ (UhOh {(First $Expr *) ($Expr *) (Foo Int Int $Expr)})+ )+ (Stmt+ (Expr {delme funny} $Expr)+ (Let {x String} {e $Expr})+ )+|]+deriving stock instance (Show funny) => Show (Expr funny)+deriving stock instance (Show funny) => Show (Stmt funny)
+ app/Main.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Language.Nanopass (deflang,defpass)+import Text.Pretty.Simple (pPrint)++import qualified Lang as L0++[deflang| L0.L0 :-> L1+ (*+ (Expr+ (- Lam)+ (+ Lam {x String} {e $Expr})+ (- Nope)+ ))+ (- Stmt)+|]+deriving stock instance Show Expr++$(pure [])++[defpass|L0.L0 :-> L1|]++main :: IO ()+main = do+ let theF = L0.Lam "x"+ [ L0.Let "y" $ L0.Var "x"+ , L0.Expr () $ L0.Var "y"+ ]+ theE = L0.App theF (L0.Var "foo")+ pPrint theE+ pPrint $ compile theE++compile :: L0.Expr () -> Expr+compile = descendExprI xlate+ where+ xlate = XlateI+ { exprI = const Nothing+ , exprLamI = \var body -> case body of+ [] -> Lam var $ Var var+ L0.Expr () e1 : _ -> Lam var $ compile e1+ L0.Let _ body1 : _ -> Lam var $ compile body1+ , exprNopeI = Var+ }
+ nanopass.cabal view
@@ -0,0 +1,52 @@+cabal-version: 3.0+name: nanopass+version: 0.0.2.0+synopsis: An EDSL for creating compilers using small passes and many intermediate representations.+description: See README+category: Language+homepage: https://github.com/edemko/nanopass+bug-reports: https://github.com/edemko/nanopass/issues+author: Eric Demko+maintainer: zankoku.okuno@gmail.com+copyright: 2022 Eric Demko+license: BSD-3-Clause+license-file: LICENSE+extra-source-files: README.md, CHANGELOG.md, LICENSE++source-repository head+ type: git+ location: https://github.com/edemko/nanopass++library+ hs-source-dirs: src+ exposed-modules:+ Language.Nanopass+ other-modules:+ Language.Nanopass.LangDef+ Language.Nanopass.QQ+ Language.Nanopass.Xlate+ Text.Parse.Stupid+ build-depends:+ , base >=4.11.1 && <4.17+ , containers >=0.6 && <0.7+ , mtl >=2.2 && <2.3+ , template-haskell >=2.18 && <2.19+ , transformers >=0.5.6 && <0.6+ default-language: Haskell2010+ ghc-options: -Wall -Wunticked-promoted-constructors++executable dumb-nanopass-example+ hs-source-dirs: app+ main-is: Main.hs+ other-modules:+ Lang+ build-depends:+ , base >=4.11.1 && <4.17+ , nanopass+ , pretty-simple >=4 && <4.1+ , template-haskell >=2.18 && <2.19+ , transformers >=0.5.6 && <0.6+ default-language: Haskell2010+ ghc-options:+ -Wall -Wunticked-promoted-constructors+ -O2 -threaded
+ src/Language/Nanopass.hs view
@@ -0,0 +1,11 @@+-- | Nanopass consists essentially of creating languages and defining passes.+-- Languages can be created from scratch or by derivation using 'deflang'.+-- The tedious parts of a compiler pass (or at least, most passes) can be generated with 'defpass'.+--+-- More details and examples are given in the [readme](https://github.com/edemko/nanopass/blob/master/README.md).+module Language.Nanopass+ ( deflang+ , defpass+ ) where++import Language.Nanopass.QQ (deflang,defpass)
+ src/Language/Nanopass/LangDef.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Language.Nanopass.LangDef+ ( TypeDesc(..)+ , LangDef(..)+ , SyncatDef(..)+ , ProdDef(..)+ , SubtermDef(..)+ , Define+ , runDefine+ , defineLang+ , DefdLang(..)+ , DefdSyncatType(..)+ , DefdProd(..)+ , DefdSubterm(..)+ , reifyLang+ , LangMod(..)+ , SyncatMod(..)+ , ProdMod(..)+ , runModify+ , modifyLang+ ) where++import Control.Monad (forM,forM_,foldM,when)+import Control.Monad.State (StateT,gets,modify,evalStateT)+import Data.Bifunctor (second)+import Data.Functor ((<&>))+import Data.List (nub,(\\),stripPrefix)+import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Language.Haskell.TH (Q, Dec)++import qualified Control.Monad.Trans as M+import qualified Data.Map as Map+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH++data TypeDesc+ = RecursiveType String -- these are metavariables that start with a lowercase letter+ | VarType TH.Name+ | CtorType TH.Name [TypeDesc] -- the string here will be used to look up a type in scope at the splice site, and will start with an uppercase letter+ | ListType TypeDesc -- because otherwise, you'd have to always be saying `type List a = [a]`+ | MaybeType TypeDesc+ | NonEmptyType TypeDesc+ | TupleType TypeDesc TypeDesc [TypeDesc]+ | MapType TypeDesc TypeDesc+ deriving(Eq,Show)++---------------------------------+------ 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+ }++runDefine :: Define a -> Q a+runDefine = flip evalStateT st0+ where+ st0 = DefState+ { langTyvars = errorWithoutStackTrace "internal nanopass error: uninitialized langTyVars"+ , syncatNames = Map.empty+ }++defineLang :: LangDef -> Define [Dec]+defineLang l = do+ -- initialize language type variables+ let duplicateParams = l.langParamReqs \\ nub l.langParamReqs+ 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+ Nothing -> modify $ \st ->+ st{syncatNames = Map.insert syncatReq (TH.mkName syncatReq) knownNames}+ Just _ -> fail $ concat [ "in a nanopass language definition: "+ , "duplicate syntactic category (terminal/nonterminal) name "+ , syncatReq+ ]+ -- define a type with one nullary ctor for every grammatical type+ langInfo <- defineLanginfo 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+ prodCtors+ []+ pure $ langInfo : syncatTypeDecs++defineLanginfo :: LangDef -> Define Dec+defineLanginfo l = do+ syncatNames <- gets $ Map.toAscList . syncatNames+ ctors <- forM syncatNames $ \(syncatName, _) -> do+ let ctorName = TH.mkName $ l.langNameReq ++ "_" ++ syncatName+ M.lift $ TH.addModFinalizer $ TH.putDoc (TH.DeclDoc ctorName) $+ "Serves as a reference to the syntactic category of t'" ++ syncatName ++ "'s."+ pure $ TH.NormalC ctorName []+ let thName = TH.mkName l.langNameReq+ 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+ [ ""+ , "This language was generated based on the langauge t'" ++ show l0.defdLangName ++ "'"+ , "using the following 'Language.Nanopass.deflang' program:"+ , ""+ , unlines . fmap ("> " ++) . lines $ origProg+ ]+ (Just l0, Nothing) -> unlines+ [ ""+ , "This language was generated based on the langauge t'" ++ show l0.defdLangName ++ "'."+ ]+ (Nothing, Just origProg) -> unlines+ [ ""+ , "This language was generated from the following 'Language.Nanopass.deflang' program:"+ , ""+ , unlines . fmap ("> " ++) . lines $ origProg+ ]+ (Nothing, Nothing) -> ""+ ]+ -- I'm not sure I need these singe this type is just a glorified set of pointers, but here they are for reference+ -- dShow = TH.DerivClause Nothing [TH.ConT ''Show]+ -- dRead = TH.DerivClause Nothing [TH.ConT ''Read]+ pure $ TH.DataD [] thName [] Nothing ctors []++defineProduction :: ProdDef -> 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++defineSubterm :: (String, TypeDesc) -> Define TH.VarBangType+defineSubterm (langName, typeDesc) = do+ ty <- subtermType typeDesc+ pure (TH.mkName langName, noBang, ty)++subtermType :: TypeDesc -> Define TH.Type+subtermType (RecursiveType lName) =+ gets (Map.lookup lName . syncatNames) >>= \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]+subtermType (VarType vName) =+ gets ((vName `elem`) . langTyvars) >>= \case+ True -> do+ pure $ TH.VarT vName+ False -> fail $ concat ["in a nanopass language definition: unknown langauge parameter ", show vName]+subtermType (CtorType thName argDescs) = do+ args <- subtermType `mapM` argDescs+ pure $ foldl TH.AppT (TH.ConT thName) args+subtermType (ListType argDesc) = do+ arg <- subtermType argDesc+ pure $ TH.AppT TH.ListT arg+subtermType (NonEmptyType argDesc) = do+ neType <- M.lift [t|NonEmpty|]+ arg <- subtermType argDesc+ pure $ TH.AppT neType arg+subtermType (MaybeType argDesc) = do+ maybeType <- M.lift [t|Maybe|]+ arg <- subtermType argDesc+ pure $ TH.AppT maybeType arg+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+ -- determine the language's grammar types+ thSyncats <- findRecursiveType `mapM` syncatPtrs+ let sNames = thSyncats <&> \(qualSName, _, _) -> qualSName+ syncatTypeList <- forM thSyncats $ \(qualSyncatName, paramNames, thCtors) -> do+ ctorList <- decodeCtor sNames paramNames `mapM` thCtors+ let productions = ctorList <&> \ctor -> ((TH.nameBase . defdProdName) ctor, ctor)+ prodNames = fst <$> productions+ duplicatePNames = prodNames \\ nub prodNames+ case duplicatePNames of+ [] -> pure DefdSyncatType+ { defdSyncatName = qualSyncatName+ , defdProds = Map.fromList productions+ }+ _ -> 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+ when (not $ null duplicateSNames) $ fail $+ "corrupt language has duplicate syntactic category names: " ++ show (nub duplicateSNames)+ -- determine the language's type parameters+ defdLangParams <-+ 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"+ , " " ++ show tvs ++ "\n"+ , "got:\n"+ , " " ++ show (fixup <$> tvs')+ ]+ in fromMaybe [] <$> foldM f Nothing thSyncats+ -- and we're done+ pure $ DefdLang+ { langQualPrefix+ , defdLangName+ , defdLangParams+ , defdSyncats = Map.fromList syncatTypes+ }+ where+ -- this is here because TH will add a bunch of garbage on the end of a type variable to ensure it doesn't capture,+ -- but in this case I _want_ it to capture, so I can check name equality across different types+ fixup :: TH.Name -> TH.Name+ fixup = TH.mkName . 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 $ \(thFieldName, _, thSubtermType) -> do+ typeDesc <- decodeType sNames paramNames thSubtermType+ pure $ DefdSubterm thFieldName typeDesc+ pure $ DefdProd{defdProdName,defdSubterms}+ decodeCtor _ _ otherCtor = fail $ "corrupt production type:\n" ++ show otherCtor+ decodeType :: [TH.Name] -> [TH.Name] -> TH.Type -> Q TypeDesc+ decodeType sNames paramNames type0 = recurse type0+ where+ tvs = TH.VarT <$> paramNames+ recurse tuple | Just (t1:t2:ts) <- fromTuple tuple = do+ t1Desc <- recurse t1+ 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+ decodedArgs <- recurse `mapM` args+ pure $ CtorType thName decodedArgs+ recurse (TH.VarT a) = pure $ VarType a+ 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+ Just (0, ts) -> Just (reverse ts)+ _ -> Nothing+ where+ loop (TH.TupleT n) = Just (n, [])+ loop (TH.AppT f t)+ | Just (n, ts) <- loop f = Just (n - 1, t:ts)+ loop _ = Nothing+ fromApps :: TH.Type -> (TH.Type, [TH.Type])+ fromApps = second reverse . loop+ where+ 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)+ otherInfo -> fail $ concat+ [ "in a nanopass language extension: base name " ++ langName ++ " 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.NormalC thTypePtr []) = do+ let enumPrefix = langBase ++ "_"+ typePtrBase <- case stripPrefix enumPrefix (TH.nameBase thTypePtr) of+ Just it -> pure it+ 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"+ , " " ++ TH.nameBase thTypePtr+ ]+ let typePtr = TH.mkName $ langQualPrefix ++ typePtrBase+ TH.reify typePtr >>= \case+ TH.TyConI (TH.DataD [] qualSyncatName thParams _ ctors _) -> do+ 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+ findRecursiveType otherCtor = fail $ concat+ [ "in a nanopass language extension: base name " ++ langName ++ " does not identify a language: "+ , " expecting language name to identify an enum, but got this constructor:\n"+ , " " ++ show otherCtor+ ]++--------------------------------+------ 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+ 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
+ src/Language/Nanopass/QQ.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TupleSections #-}++module Language.Nanopass.QQ+ ( deflang+ , defpass+ ) where++import Data.Char+import Language.Nanopass.LangDef+import Prelude hiding (mod)+++import Control.Monad (forM)+import Language.Haskell.TH (Q, Dec)+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Nanopass.Xlate (mkXlate)+import Text.Parse.Stupid (Sexpr(..))+++import qualified Language.Haskell.TH as TH+import qualified Text.Parse.Stupid as Stupid++-- | 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.+--+-- > 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⟩+-- > +-- > 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+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\+ \it can only appear as part of declarations."++-- | Define automatic translation between two langauges.+-- This creates an @Xlate@ type and the @descend\<Syntactic Category\>@ family of functions,+-- as well as pure variants (@XlateI@ and @descend\<Syntactic Category\>I@) and a lifting function @idXlate@.+-- A translation function is generated for each syntactic category with the same name in both source and target languages.+-- 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 @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.+--+-- The type of a @descend\<Syntactic Category\>@ function is+-- @Xlate f → σ → f σ'@.+--+-- 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 source language has syntactic category @σ@ with the same name as the target's syntactic category @σ'@,+-- 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'.+--+-- The pure variants have the same form as the 'Applicative' ones, but:+--+-- * @XlateI@ is not parameterized by @f@, nor are the types of its members,+-- * the members of @XlateI@ are suffixed with the letter @I@, and+-- * the types of the @descend\<Syntactic Category\>I@ functions are not parameterzed by @f@.+--+-- The @idXlate@ function is used by Nanopass to translate @XlateI@ values into @Xlate@ values.+-- This is done so that the same code paths can be used for both pure and 'Applicative' translations.+-- Under the hood, this is done with appropriate wrapping/unwrapping of v'Data.Functor.Identity.Identity', which is a no-op.+--+-- None of the functions defined by this quasiquoter need to be expoted for Nanopass to function.+-- I expect you will not export any of these definitions directly, but instead wrap them into a complete pass, and only export that pass.+--+-- 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⟩+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+ mkXlate l1 l2+ Left err -> fail err+ 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 "*":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 == '_'
+ src/Language/Nanopass/Xlate.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}++module Language.Nanopass.Xlate+ ( mkXlate+ , declareXlate+ , XlateDef(..)+ , XlateProd+ , XlateAuto(..)+ , XlateHoleDef(..)+ , XlateSyncatDef(..)+ ) where++import Language.Nanopass.LangDef++import Control.Monad (forM)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Either (lefts)+import Data.Functor ((<&>))+import Data.Functor.Identity (Identity(..))+import Data.List (nub)+import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map)+import Language.Haskell.TH (Exp(AppE,VarE))+import Language.Haskell.TH (Q,Dec)+import Language.Haskell.TH (Type(AppT))++import qualified Control.Monad.Trans as M+import qualified Data.Char as Char+import qualified Data.Map as Map+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH+++mkXlate :: DefdLang -> DefdLang -> Q [Dec]+mkXlate l1 l2 = xlateDef l1 l2 >>= declareXlate l1 l2++declareXlate :: DefdLang -> DefdLang -> XlateDef -> Q [Dec]+declareXlate l1 l2 xlate = do+ xlateType <- declareType xlate+ xlateTypeI <- declareTypeI xlate+ xlateLifter <- declareXlateLifter xlate+ descends <- defineDescend l1 l2 xlate+ pure $ xlateType : xlateTypeI : xlateLifter ++ descends++---------------------------------------------+------ Gather Translation Requirements ------+---------------------------------------------++data XlateDef = XlateDef+ { xlateParams :: [TH.Name] -- ^ the type parameters of both languages, merged+ , xlateFParam :: TH.Name -- ^ a type for an Applicative parameter+ , xlateSyncats :: [XlateSyncatDef]+ -- ^ information about the syntactic cateories shared by both source and target+ -- this is used to allow users to override the bahavior of automatic translation+ , xlateProds :: [XlateProd] -- FIXME these should go under xlateSyncats, probly+ -- ^ information about the productions in the source that are missing in the target+ -- this is so that we require the user to supply these in an Xlate type+ , xlateFrom :: DefdLang+ , xlateTo :: DefdLang+ }+type XlateProd = Either XlateHoleDef XlateAuto+data XlateAuto = XlateAuto+ { syncatName :: String+ , prodName :: String+ , 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+ , 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+ , 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 l1 l2 = do+ let xlateParams = nub (l1.defdLangParams ++ l2.defdLangParams)+ 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+ pure $ XlateDef+ { xlateParams+ , xlateFParam+ , xlateSyncats+ , 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+ 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+ where+ detectHoleCtors :: DefdSyncatType -> (String, DefdProd) -> Q [Either XlateHoleDef XlateAuto]+ detectHoleCtors s2 (pName, prod1) = case Map.lookup pName s2.defdProds 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 == 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}]+ -- a required hole, because the arguments of the constructors do not have the same structure+ | otherwise -> pure [Left $ createHole pName prod1]+ 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}++detectOverrides :: DefdLang -> DefdLang -> (String, DefdSyncatType) -> [XlateSyncatDef]+detectOverrides l1 l2 (sName, _) = case Map.lookup sName l2.defdSyncats 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}]++createAuto :: TypeDesc -> MaybeT Q (TH.Name -> TH.Name -> Exp)+createAuto (RecursiveType sName) = do+ let repName = TH.mkName $ "descend" ++ sName+ auto xlateVar argVar = VarE repName `AppE` VarE xlateVar `AppE` VarE argVar+ pure auto+createAuto (VarType _) = do+ let auto _ argVar = VarE 'pure `AppE` VarE argVar+ pure auto+createAuto (CtorType tyName ts)+ | all (not . containsGrammar) ts = do+ let auto _ argVar = VarE 'pure `AppE` VarE argVar+ pure auto+ | t:ts' <- reverse ts+ , all (not . containsGrammar) ts' = do+ let travCandidate = foldl AppT (TH.ConT tyName) (interpretTypeDesc undefined <$> ts')+ isTraversable <- M.lift $ TH.isInstance ''Traversable [travCandidate]+ if isTraversable then traversableAuto t else hoistNothing+ -- TODO maybe try Bitraversable+ | otherwise = hoistNothing+createAuto (ListType t) = traversableAuto t+createAuto (MaybeType t) = traversableAuto t+createAuto (NonEmptyType t) = traversableAuto t+createAuto (TupleType t1 t2 ts) = do+ tupleMaker <- do+ tVars <- forM [1..length (t1:t2:ts)] $ \i -> M.lift $ TH.newName ("t" ++ show i)+ pure $ TH.LamE (TH.VarP <$> tVars) $ TH.TupE (Just . VarE <$> tVars)+ (args', autos') <- fmap unzip $ forM (zip [(1::Int)..] (t1:t2:ts)) $ \(i, t) -> do+ auto' <- createAuto t+ arg' <- M.lift $ TH.newName ("a" ++ show i)+ pure (arg', auto')+ let auto xlateVar argVar =+ let elemAuto auto' arg' = auto' xlateVar arg'+ lam = TH.LamE [TH.TupP $ TH.VarP <$> args'] $+ 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 t = do+ var <- M.lift $ TH.newName "x"+ auto' <- createAuto t+ let auto xlateVar argVar =+ let lam = TH.LamE [TH.VarP var] (auto' xlateVar var)+ in VarE 'traverse `AppE` lam `AppE` VarE argVar+ pure auto+++---------------------------------+------ Declare XLate Types ------+---------------------------------++declareType :: XlateDef -> Q Dec+declareType x = do+ TH.addModFinalizer $ TH.putDoc (TH.DeclDoc xlateName) $ unlines+ [ "This type is used to parameterize the nanopass-generated translation functions @descend\\<Syntactic Category\\>@."+ , "It has members for:"+ , ""+ , " * each constructor that could not be translated"+ , " (because it does not appear in the target language,"+ , " because it has different subterms in the target language, or"+ , " because nanopass does not understand the type of one or more of the subterms)"+ , " * each syntactic category of the source language shared by the target,"+ , " which allows a pass to override the default translation."+ , " When no override is needed, these members can be initialized with 'const Nothing'."+ ]+ holes <- forM (lefts $ xlateProds x) $ \hole -> do+ let name = TH.mkName $ lowerHead hole.syncatName ++ 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, "'"+ ]+ , "could be generated by Nanopass."+ ]+ pure (name, noBang, t)+ overrides <- forM x.xlateSyncats $ \syncat -> do+ let name = TH.mkName $ lowerHead syncat.syncatName+ r = TH.ConT ''Maybe `AppT` (TH.VarT x.xlateFParam `AppT` syncat.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 ++ "'"+ , "syntactic category."+ ]+ , "Produce a 'Just' value to override the automatic translation."+ , "If no overrides are needed, use @'const' 'Nothing'@."+ ]+ pure (name, noBang, ArrT syncat.fromType r)+ pure $ TH.DataD [] xlateName tvs Nothing+ [TH.RecC xlateName $ holes ++ overrides]+ []+ where+ xlateName = TH.mkName "Xlate"+ tvs = flip TH.PlainTV () <$> xlateParams x ++ [xlateFParam x]++declareTypeI :: XlateDef -> Q Dec+declareTypeI x = do+ TH.addModFinalizer $ TH.putDoc (TH.DeclDoc xlateName) $ unlines+ [ "This type is used to parameterize the nanopass-generated translation functions @descend*I@."+ , "It is the pure (i.e. does not require an 'Applicative') version of 'Xlate'."+ , ""+ , "See 'Xlate' for more detail."+ ]+ holes <- forM (lefts x.xlateProds) $ \hole -> do+ let name = TH.mkName $ lowerHead hole.syncatName ++ 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, "'"+ ]+ , "could be generated by Nanopass."+ ]+ pure (name, noBang, t)+ overrides <- forM x.xlateSyncats $ \syncat -> do+ let name = TH.mkName $ lowerHead syncat.syncatName ++ "I"+ r = TH.ConT ''Maybe `AppT` syncat.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 ++ "'"+ , "syntactic category."+ ]+ , "Produce a 'Just' value to override the automatic translation."+ , "If no overrides are needed, use @'const' 'Nothing'@."+ ]+ pure (name, noBang, ArrT syncat.fromType r)+ pure $ TH.DataD [] xlateName tvs Nothing+ [TH.RecC xlateName $ holes ++ overrides]+ []+ where+ xlateName = TH.mkName "XlateI"+ tvs = flip TH.PlainTV () <$> xlateParams x++declareXlateLifter :: XlateDef -> Q [Dec]+declareXlateLifter x = do+ let liftName = TH.mkName "idXlate"+ TH.addModFinalizer $ TH.putDoc (TH.DeclDoc liftName) $ unlines+ [ "This function is used by Nanopass to implement the @descend\\<Syntactic Category\\>I@ functions."+ , "It is used only to lift a pure 'XlateI' parameter into an 'Xlate'."+ , "This way, pure translations can use the same code paths as the more general 'Control.Applicative.Applicative' translations."+ , "Internally, it just arranges wrapping and unwrapping of t'Data.Functor.Identity.Identity', which are no-ops."+ ]+ let quantifier = flip TH.PlainTV TH.InferredSpec <$> x.xlateParams+ xlateApTyCon = TH.ConT $ TH.mkName "Xlate"+ xlateApTy = foldl AppT xlateApTyCon ((TH.VarT <$> x.xlateParams) ++ [TH.ConT ''Identity])+ xlateIdTyCon = TH.ConT $ TH.mkName "XlateI"+ xlateIdTy = foldl AppT xlateIdTyCon (TH.VarT <$> x.xlateParams)+ xlateVar <- TH.newName "xlate"+ holeMembers <- holes xlateVar+ ovrMembers <- overrides xlateVar+ let body = TH.RecConE (TH.mkName "Xlate") (holeMembers ++ ovrMembers)+ clause = TH.Clause [TH.VarP xlateVar] (TH.NormalB body) []+ pure+ [ TH.SigD liftName $ TH.ForallT quantifier [] $+ xlateIdTy `ArrT` xlateApTy+ , TH.FunD liftName [clause]+ ]+ where+ holes xlateVar = forM (lefts x.xlateProds) $ \hole -> do+ let nameAp = TH.mkName $ lowerHead hole.syncatName ++ hole.prodName+ nameId = TH.mkName $ lowerHead hole.syncatName ++ 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 $ lowerHead syncat.syncatName+ nameId = TH.mkName $ lowerHead syncat.syncatName ++ "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 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)+ 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 (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 l1 l2 xdef = do+ fmap concat . forM xdef.xlateSyncats $ \XlateSyncatDef{syncatName} -> do+ let funName = TH.mkName $ "descend" ++ syncatName+ funNameId = TH.mkName $ "descend" ++ syncatName ++ "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."+ ]+ , ""+ , "Some (hopefully most) of this function was automatically generated by nanopass."+ , unwords+ [ "It is parameterized by an t'Xlate', which"+ , "fills holes for which nanopass could not automatcially determine a translation, and also"+ , "allows for automatic translation to be overridden."+ ]+ ]+ 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."+ ]+ , ""+ , "This is the pure (i.e. no 'Applicative' required) version of '"++show funName++"'."+ , "This version is parameterized by an t'XlateI' rather than an t'Xlate'."+ , "See '"++show funName++"' for more details."+ ]+ 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+ -- 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+ -- if this production has a hole, call the hole+ Just (Left _) ->+ let f = TH.mkName $ lowerHead syncatName ++ pName+ 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)+ iAppE a b = TH.InfixE (Just a) (VarE '(<*>)) (Just b)+ es = zipWith ($) (auto.autoArgs <&> ($ xlateVar)) args+ in foldl iAppE e0 es+ Nothing -> error "internal nanopass error: found neither hole nor auto"+ pure $ TH.Match pat (TH.NormalB body) []+ 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 $ lowerHead syncatName)+ `AppE` (VarE xlateVar)+ `AppE` (VarE termVar)+ ovrMatches =+ [ TH.Match (TH.ConP 'Just [] [TH.VarP termVar']) (TH.NormalB $ VarE termVar') []+ , TH.Match (TH.ConP 'Nothing [] []) (TH.NormalB autoBody) []+ ]+ -- tie it all together+ let body = TH.CaseE override ovrMatches+ clause = TH.Clause [TH.VarP xlateVar, TH.VarP termVar] (TH.NormalB body) []+ let delegateId = TH.VarE funName `AppE` (TH.VarE (TH.mkName "idXlate") `AppE` TH.VarE xlateVar)+ bodyId = TH.InfixE (Just $ TH.VarE 'runIdentity) (TH.VarE '(.)) (Just delegateId)+ clauseId = TH.Clause [TH.VarP xlateVar] (TH.NormalB bodyId) []+ -- generate a type signature+ let quantifier = flip TH.PlainTV TH.InferredSpec <$> xdef.xlateParams ++ [xdef.xlateFParam]+ 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)+ l2ResTy = AppT (TH.VarT xdef.xlateFParam) l2ResTyCore+ let quantifierId = flip TH.PlainTV TH.InferredSpec <$> xdef.xlateParams+ xlateArgTyConId = TH.ConT $ TH.mkName "XlateI"+ xlateArgTyId = foldl AppT xlateArgTyConId (TH.VarT <$> xdef.xlateParams)+ l2ResTyId = l2ResTyCore+ -- and emit both signature and definition+ pure+ [ TH.SigD funName $ TH.ForallT quantifier [appClass] $+ xlateArgTy `ArrT` (l1ArgTy `ArrT` l2ResTy)+ , TH.FunD funName [clause]+ -- the "pure" (i.e. non-applicative) version+ , TH.SigD funNameId $ TH.ForallT quantifierId [] $+ xlateArgTyId `ArrT` (l1ArgTy `ArrT` l2ResTyId)+ , TH.FunD funNameId [clauseId]+ ]++---------------------+------ Helpers ------+---------------------++pattern ArrT :: TH.Type -> TH.Type -> TH.Type+pattern ArrT a b = AppT (AppT TH.ArrowT a) b++idiomAppE :: Exp -> Exp -> Exp+idiomAppE a b = TH.InfixE (Just a) (VarE '(<*>)) (Just b)++noBang :: TH.Bang+noBang = TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness++containsGrammar :: TypeDesc -> 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 (TupleType t1 t2 ts) = any containsGrammar (t1:t2:ts)+containsGrammar (MapType t1 t2) = containsGrammar t1 || containsGrammar t2++findAuto :: String -> String -> [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+++lowerHead :: String -> String+lowerHead [] = []+lowerHead (c:cs) = Char.toLower c : cs++hoistNothing :: Monad m => MaybeT m a+hoistNothing = MaybeT $ pure Nothing
+ src/Text/Parse/Stupid.hs view
@@ -0,0 +1,69 @@+{-# 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