diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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` 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`. +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` 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 `descendI`. + 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. diff --git a/app/Lang.hs b/app/Lang.hs new file mode 100644 --- /dev/null +++ b/app/Lang.hs @@ -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) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 + } diff --git a/nanopass.cabal b/nanopass.cabal new file mode 100644 --- /dev/null +++ b/nanopass.cabal @@ -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 diff --git a/src/Language/Nanopass.hs b/src/Language/Nanopass.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nanopass.hs @@ -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) diff --git a/src/Language/Nanopass/LangDef.hs b/src/Language/Nanopass/LangDef.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nanopass/LangDef.hs @@ -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 diff --git a/src/Language/Nanopass/QQ.hs b/src/Language/Nanopass/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nanopass/QQ.hs @@ -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\@ family of functions, +-- as well as pure variants (@XlateI@ and @descend\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\@ 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\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" + , " ( )\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" + , " ( … )\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" + , " ( … )\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" + , " { }\n" + , " or \n" + , "but parsing 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" + , " $\n" + , " \n" + , " # == ($)\n" + , " ( … )\n" + , " ( <* | + | ?>… ) # list, nonempty list, and maybe\n" + , " { … } # tuple\n" + , " [ :-> ] # association list\n" + , " { :-> } # 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" + , " ( … )\n" + , "got:\n" + , " " ++ Stupid.print id other + ] +parseSyncatMod other = Left $ concat + [ "expecting syntactic category modifier batch:\n" + , " (+ … )\n" + , " (* … )\n" + , " (- … )\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" + , " (+ … )\n" + , " (- )\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 == '_' diff --git a/src/Language/Nanopass/Xlate.hs b/src/Language/Nanopass/Xlate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Nanopass/Xlate.hs @@ -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\\@." + , "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\\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 diff --git a/src/Text/Parse/Stupid.hs b/src/Text/Parse/Stupid.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parse/Stupid.hs @@ -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