nanopass 0.0.2.0 → 0.0.2.1
raw patch · 8 files changed
+97/−57 lines, 8 filesdep ~basedep ~mtldep ~pretty-simplePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, mtl, pretty-simple, template-haskell, transformers
API changes (from Hackage documentation)
Files
- CHANGELOG.md +15/−1
- LICENSE +2/−2
- README.md +4/−4
- app/Main.hs +8/−9
- nanopass.cabal +20/−15
- src/Language/Nanopass/LangDef.hs +14/−3
- src/Language/Nanopass/QQ.hs +18/−1
- src/Language/Nanopass/Xlate.hs +16/−22
CHANGELOG.md view
@@ -1,6 +1,20 @@ # Revision history for nanopass -## 0.0.2.0 -- YYYY-mm-dd+## 0.0.3.0 -- YYYY-mm-dd+++## 0.0.2.1 -- 2024-01-02++* Fix bug decoding constructors with no fields+* Add missing "modifier" production rules to documentation+* Allow parentheses drop when a syncat modifier has exactly one child+* add `on` prefix to Xlate records to avoid ambiguous records+* require `Xlate{,I}` fields to be strict so they don't get forgotten when you write translators+* because nanopass creates partial-fields (detectable with `-Wpartial-fields`),+ I've decided to prefix these with double-underscore to indicate that they are not meant for use+ beyond nanopass' internals++## 0.0.2.0 -- 2022-02-11 * Generate documentation for the members of `Xlate` and `XlateI`. * Add generation of pure variants of translation facilities to `defpass`.
LICENSE view
@@ -1,4 +1,4 @@-Copyright Eric Demko (c) 2022+Copyright Marseille Bouchard (c) 2022 All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Eric Demko nor the names of other+ * Neither the name of Marseille Bouchard nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
README.md view
@@ -49,7 +49,7 @@ ``` {-# LANGUAGE QuasiQuotes #-} module Lambda where-import Data.Language.Nanopass (deflang)+import Language.Nanopass (deflang) [deflang| Lambda (Expr@@ -67,7 +67,7 @@ ``` module LambdaLet where-import Data.Language.Nanopass (deflang, defpass)+import Language.Nanopass (deflang, defpass) import Data.Functor.Identity (Identity(runIdentity)) import Data.List (foldl1) @@ -100,9 +100,9 @@ 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+ { onExprLet = \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+ , onExpr = const Nothing -- we don't need to override anything } unlet body (x, e) = (Lam x body) `App` e ```
app/Main.hs view
@@ -11,12 +11,11 @@ import qualified Lang as L0 [deflang| L0.L0 :-> L1- (*- (Expr- (- Lam)- (+ Lam {x String} {e $Expr})- (- Nope)- ))+ (* Expr+ (- Lam)+ (+ Lam {x String} {e $Expr})+ (- Nope)+ ) (- Stmt) |] deriving stock instance Show Expr@@ -39,10 +38,10 @@ compile = descendExprI xlate where xlate = XlateI- { exprI = const Nothing- , exprLamI = \var body -> case body of+ { onExprI = const Nothing+ , onExprLamI = \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+ , onExprNopeI = Var }
nanopass.cabal view
@@ -1,17 +1,23 @@ 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+version: 0.0.2.1+synopsis: Create compilers using small passes and many intermediate representations.+description:+ Uses Template Haskell to facilitate using a vast number of intermediate representations.+ On the one hand, it can generate data types for syntax trees based on their relationships.+ Further, generates the boilerplate for writing transformations between related syntax trees.+ + See README.md for more details. category: Language homepage: https://github.com/edemko/nanopass bug-reports: https://github.com/edemko/nanopass/issues-author: Eric Demko+author: Marseille Bounchard maintainer: zankoku.okuno@gmail.com-copyright: 2022 Eric Demko+copyright: 2022 Marseille Bounchard license: BSD-3-Clause license-file: LICENSE-extra-source-files: README.md, CHANGELOG.md, LICENSE+extra-source-files:+extra-doc-files: README.md, CHANGELOG.md, LICENSE source-repository head type: git@@ -27,11 +33,11 @@ Language.Nanopass.Xlate Text.Parse.Stupid build-depends:- , base >=4.11.1 && <4.17+ , base >=4.11.1 && <4.19 , containers >=0.6 && <0.7- , mtl >=2.2 && <2.3- , template-haskell >=2.18 && <2.19- , transformers >=0.5.6 && <0.6+ , mtl >=2.2 && <2.4+ , template-haskell >=2.18 && <2.21+ , transformers >=0.5.6 && <0.7 default-language: Haskell2010 ghc-options: -Wall -Wunticked-promoted-constructors @@ -41,12 +47,11 @@ other-modules: Lang build-depends:- , base >=4.11.1 && <4.17+ , base >=4.11.1 && <4.19 , nanopass- , pretty-simple >=4 && <4.1- , template-haskell >=2.18 && <2.19- , transformers >=0.5.6 && <0.6+ , pretty-simple >=4 && <4.2+ , template-haskell >=2.18 && <2.21+ , transformers >=0.5.6 && <0.7 default-language: Haskell2010 ghc-options: -Wall -Wunticked-promoted-constructors- -O2 -threaded
src/Language/Nanopass/LangDef.hs view
@@ -170,8 +170,8 @@ 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)+ 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@@ -311,10 +311,13 @@ 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+ defdSubterms <- forM thFields $ \(thFieldNameDunder, _, thSubtermType) -> do+ thFieldName <- removeDunder thFieldNameDunder typeDesc <- decodeType sNames paramNames thSubtermType pure $ DefdSubterm thFieldName typeDesc pure $ DefdProd{defdProdName,defdSubterms}+ decodeCtor _ _ (TH.NormalC defdProdName []) =+ pure $ DefdProd{defdProdName,defdSubterms=[]} decodeCtor _ _ otherCtor = fail $ "corrupt production type:\n" ++ show otherCtor decodeType :: [TH.Name] -> [TH.Name] -> TH.Type -> Q TypeDesc decodeType sNames paramNames type0 = recurse type0@@ -499,3 +502,11 @@ noBang :: TH.Bang noBang = TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness++removeDunder :: TH.Name -> Q TH.Name+removeDunder name = case TH.nameBase name of+ '_':'_':str -> pure $ TH.mkName str+ other -> fail $ concat+ [ "corrupt subterm field name (must start with double-underscore):\n"+ , " ", show other+ ]
src/Language/Nanopass/QQ.hs view
@@ -58,6 +58,15 @@ -- > ::= { ⟨lowName⟩ ⟨type⟩ } -- > | ⟨type⟩ -- > +-- > syntactic category modifier+-- > ::= ( + ⟨syntactic category⟩… )+-- > | ( - ⟨UpName⟩… )+-- > | ( * ⟨UpName⟩ ⟨production modifier⟩… )+-- > | ( * ( ⟨UpName⟩ ⟨production modifier⟩… )… )+-- > production modifier+-- > ::= ( + ⟨UpName⟩ ⟨subterm⟩… )+-- > | ( - ⟨UpName⟩ )+-- > -- > type -- > ::= $⟨UpName⟩ # reference a syntactic category -- > | ⟨lowName⟩ # type parameter@@ -312,6 +321,14 @@ forM syncatExprs $ \case (Atom syncatStr) | Just sName <- fromUpname syncatStr -> pure $ DelSyncat sName other -> Left $ "expecting the name of a syntactic category, got:\n " ++ Stupid.print id other+parseSyncatMod (Combo "(" (Atom "*":Atom sStr:pModExprs))+ | Just sName <- fromUpname sStr = do+ pMods <- parseProdMod `mapM` pModExprs+ pure [ModProds sName pMods]+ | otherwise = Left $ concat+ [ "expecting syntactic category name"+ , ", got: ", show sStr+ ] parseSyncatMod (Combo "(" (Atom "*":syncatExprs)) = forM syncatExprs $ \case (Combo "(" (Atom sStr:pModExprs))@@ -322,7 +339,7 @@ [ "expecting syntactic category modifier:\n" , " (<SyncatName> <ctor mods>… )\n" , "got:\n"- , " " ++ Stupid.print id other+ , " ", Stupid.print id other ] parseSyncatMod other = Left $ concat [ "expecting syntactic category modifier batch:\n"
src/Language/Nanopass/Xlate.hs view
@@ -30,7 +30,6 @@ 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@@ -203,7 +202,7 @@ , " 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+ let name = TH.mkName $ "on" ++ 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@@ -214,9 +213,9 @@ ] , "could be generated by Nanopass." ]- pure (name, noBang, t)+ pure (name, bang, t) overrides <- forM x.xlateSyncats $ \syncat -> do- let name = TH.mkName $ lowerHead syncat.syncatName+ let name = TH.mkName $ "on" ++ 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"@@ -227,7 +226,7 @@ , "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 (name, bang, ArrT syncat.fromType r) pure $ TH.DataD [] xlateName tvs Nothing [TH.RecC xlateName $ holes ++ overrides] []@@ -244,7 +243,7 @@ , "See 'Xlate' for more detail." ] holes <- forM (lefts x.xlateProds) $ \hole -> do- let name = TH.mkName $ lowerHead hole.syncatName ++ hole.prodName ++ "I"+ let name = TH.mkName $ "on" ++ hole.syncatName ++ hole.prodName ++ "I" t = foldr ArrT hole.holeResult hole.holeArgs TH.addModFinalizer $ TH.putDoc (TH.DeclDoc name) $ unlines [ "No automatic translation for"@@ -254,9 +253,9 @@ ] , "could be generated by Nanopass." ]- pure (name, noBang, t)+ pure (name, bang, t) overrides <- forM x.xlateSyncats $ \syncat -> do- let name = TH.mkName $ lowerHead syncat.syncatName ++ "I"+ let name = TH.mkName $ "on" ++ 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"@@ -267,7 +266,7 @@ , "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 (name, bang, ArrT syncat.fromType r) pure $ TH.DataD [] xlateName tvs Nothing [TH.RecC xlateName $ holes ++ overrides] []@@ -301,8 +300,8 @@ ] 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"+ let nameAp = TH.mkName $ "on" ++ hole.syncatName ++ hole.prodName+ nameId = TH.mkName $ "on" ++ hole.syncatName ++ hole.prodName ++ "I" subtermNames <- forM hole.holeArgs $ \_ -> do TH.newName "subterm" let lam = TH.LamE (TH.VarP <$> subtermNames) body@@ -310,8 +309,8 @@ 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"+ let nameAp = TH.mkName $ "on" ++ syncat.syncatName+ nameId = TH.mkName $ "on" ++ 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)@@ -389,7 +388,7 @@ 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+ let f = TH.mkName $ "on" ++ syncatName ++ pName recurse = VarE f `AppE` VarE xlateVar in foldl AppE recurse (VarE <$> args) Just (Right auto) ->@@ -402,7 +401,7 @@ let autoBody = TH.CaseE (VarE termVar) autoMatches -- define the case match on the result of the override termVar' <- TH.newName "term"- let override = VarE (TH.mkName $ lowerHead syncatName)+ let override = VarE (TH.mkName $ "on" ++ syncatName) `AppE` (VarE xlateVar) `AppE` (VarE termVar) ovrMatches =@@ -450,8 +449,8 @@ idiomAppE :: Exp -> Exp -> Exp idiomAppE a b = TH.InfixE (Just a) (VarE '(<*>)) (Just b) -noBang :: TH.Bang-noBang = TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness+bang :: TH.Bang+bang = TH.Bang TH.NoSourceUnpackedness TH.SourceStrict containsGrammar :: TypeDesc -> Bool containsGrammar (RecursiveType _) = True@@ -471,11 +470,6 @@ 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