pinchot 0.16.0.0 → 0.18.0.0

raw patch · 12 files changed

+495/−51 lines, 12 filesdep +semigroupsdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: semigroups

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• lib/Pinchot.hs +5/−1
• lib/Pinchot/Earley.hs +3/−5
• lib/Pinchot/Examples/AllRulesRecord.hs +1/−1
• lib/Pinchot/Examples/SyntaxTrees.hs +10/−4
• lib/Pinchot/Examples/Terminalize.hs +1/−1
• lib/Pinchot/NonEmpty.hs +5/−0
• lib/Pinchot/SyntaxTree.hs +13/−17
• lib/Pinchot/SyntaxTree/Instancer.hs +402/−0
• lib/Pinchot/SyntaxTree/Optics.hs +0/−3
• lib/Pinchot/Terminalize.hs +3/−13
• oldTemplateHaskell/Pinchot/Internal/TemplateHaskellShim.hs +15/−0
• pinchot.cabal +37/−6

@@ -83,8 +83,11 @@   , syntaxTrees   , allRulesRecord -  -- ** Wrappers and optics+  -- ** Typeclass instances and optics   , wrappedInstances+  , bifunctorInstances+  , semigroupInstances+  , monoidInstances   , rulesToOptics    -- * Creating Earley grammars@@ -113,6 +116,7 @@ import Pinchot.NonEmpty import Pinchot.Rules import Pinchot.SyntaxTree+import Pinchot.SyntaxTree.Instancer import Pinchot.SyntaxTree.Optics import Pinchot.SyntaxTree.Wrappers import Pinchot.Terminalize

@@ -15,6 +15,7 @@ import Data.Sequence ((<|), viewl, ViewL(EmptyL, (:<)), Seq) import qualified Data.Sequence as Seq import qualified Language.Haskell.TH as T+import Pinchot.Internal.TemplateHaskellShim (dataD) import qualified Language.Haskell.TH.Syntax as Syntax import qualified Text.Earley @@ -164,9 +165,6 @@   :: Qualifier   -- ^ Qualifier for data types corresponding to those created from   -- the 'Rule's-  -> T.Name-  -- ^ Name of terminal type.  Typically you will get this through-  -- the Template Haskell quoting mechanism, such as @''Char@.   -> Seq (Rule t)   -- ^ A record is created that holds a value for each 'Rule'   -- in the 'Seq', as well as for every ancestor of these 'Rule's.@@ -178,8 +176,8 @@   --   -- where @NAME@ is the name of the type.  Don't count on these   -- records being in any particular order.-allRulesRecord prefix termName ruleSeq-  = sequence [T.dataD (return []) (T.mkName nameStr) tys [con] []]+allRulesRecord prefix ruleSeq+  = sequence [dataD (return []) (T.mkName nameStr) tys [con] []]   where     nameStr = "Productions"     tys = [T.PlainTV (T.mkName "r"), T.PlainTV (T.mkName "t"),

@@ -11,4 +11,4 @@ import Pinchot.Examples.Postal import qualified Pinchot.Examples.SyntaxTrees as SyntaxTrees -$(allRulesRecord "SyntaxTrees" ''Char [rAddress])+$(allRulesRecord "SyntaxTrees" [rAddress])

@@ -14,16 +14,22 @@ module Pinchot.Examples.SyntaxTrees where  import Pinchot-import Pinchot.SyntaxTree.Wrappers import Pinchot.Examples.Postal -import qualified Control.Lens as Lens- -- This generates the data types corresponding to the 'rAddress' -- 'Rule', as well as all the ancestors of that 'Rule'.-$(syntaxTrees ''Char+$(syntaxTrees   [''Eq, ''Ord, ''Show, ''Foldable, ''Traversable, ''Functor]   [rAddress])  -- This generates intances of the Lens Wrapped typeclass. $(wrappedInstances [rAddress])++-- This generates instances of the Bifunctor typeclass.+$(bifunctorInstances [rAddress])++-- This generates instances of the Semigroup typeclass.+$(semigroupInstances [rAddress])++-- This generates instances of the Monoid typeclass.+$(monoidInstances [rAddress])

@@ -13,4 +13,4 @@ terminalizeAddress :: SyntaxTrees.Address t a -> NonEmpty (t, a) terminalizeAddress = $(terminalizeRuleExp "SyntaxTrees" rAddress) -$(terminalizers "SyntaxTrees" ''Char [rAddress])+$(terminalizers "SyntaxTrees" [rAddress])

@@ -6,6 +6,7 @@ module Pinchot.NonEmpty where  import Control.Monad (join, ap)+import Data.Semigroup (Semigroup((<>))) import Data.Sequence (Seq, (<|)) import qualified Data.Sequence as Seq import qualified Control.Lens as Lens@@ -17,6 +18,10 @@   , _rest :: Seq a   -- ^ All remaining items   } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Semigroup (NonEmpty a) where+  (NonEmpty a1 as) <> (NonEmpty b1 bs)+    = NonEmpty a1 (as <> (b1 <| bs))  Lens.makeLenses ''NonEmpty 

@@ -7,6 +7,7 @@ import Data.Foldable (toList) import Data.Sequence (Seq) import qualified Language.Haskell.TH as T+import Pinchot.Internal.TemplateHaskellShim (newtypeD, dataD)  import Pinchot.NonEmpty import Pinchot.Rules@@ -18,15 +19,12 @@ -- applying this function to a single start symbol.  Example: -- "Pinchot.Examples.SyntaxTrees". syntaxTrees-  :: T.Name-  -- ^ Name of terminal type.  Typically you will get this from the-  -- Template Haskell quoting mechanism, e.g. @''Char@.-  -> [T.Name]+  :: [T.Name]   -- ^ What to derive, e.g. @[''Eq, ''Ord, ''Show]@   -> Seq (Rule t)   -> T.DecsQ-syntaxTrees term derives-  = traverse (ruleToType term derives)+syntaxTrees derives+  = traverse (ruleToType derives)   . toList   . families @@ -42,32 +40,30 @@  -- | Makes the top-level declaration for a given rule. ruleToType-  :: T.Name-  -- ^ Name of terminal type-  -> [T.Name]+  :: [T.Name]   -- ^ What to derive   -> Rule t   -> T.Q T.Dec-ruleToType typeName derives (Rule nm _ ruleType) = case ruleType of+ruleToType derives (Rule nm _ ruleType) = case ruleType of   Terminal _ ->-    T.newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives     where       newtypeCon = T.normalC name         [T.strictType T.notStrict           [t| ( $(charTypeVar), $(anyTypeVar) ) |] ] -  NonTerminal b1 bs -> T.dataD (T.cxt []) name [charType, anyType] cons derives+  NonTerminal b1 bs -> dataD (T.cxt []) name [charType, anyType] cons derives     where       cons = branchConstructor b1 : toList (fmap branchConstructor bs)    Wrap (Rule inner _ _) ->-    T.newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives     where       newtypeCon = T.normalC name         [ T.strictType T.notStrict             [t| $(T.conT (T.mkName inner)) $(charTypeVar) $(anyTypeVar) |] ] -  Record sq -> T.dataD (T.cxt []) name [charType, anyType] [ctor] derives+  Record sq -> dataD (T.cxt []) name [charType, anyType] [ctor] derives     where       ctor = T.recC name . zipWith mkField [(0 :: Int) ..] . toList $ sq       mkField num (Rule rn _ _) = T.varStrictType (T.mkName fldNm)@@ -77,7 +73,7 @@           fldNm = '_' : recordFieldName num nm rn    Opt (Rule inner _ _) ->-    T.newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives     where       newtypeCon = T.normalC name         [T.strictType T.notStrict@@ -85,7 +81,7 @@                                                  $(anyTypeVar)) |]]    Star (Rule inner _ _) ->-    T.newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives     where       newtypeCon = T.normalC name [sq]         where@@ -94,7 +90,7 @@                                                  $(anyTypeVar) ) |]    Plus (Rule inner _ _) ->-    T.newtypeD (T.cxt []) name [charType, anyType] cons derives+    newtypeD (T.cxt []) name [charType, anyType] cons derives     where       cons = T.normalC name [ne]         where

@@ -0,0 +1,402 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+module Pinchot.SyntaxTree.Instancer where++import qualified Data.Bifunctor as Bifunctor+import Data.Maybe (catMaybes)+import qualified Data.Semigroup as Semigroup+import qualified Control.Lens as Lens+import Data.Foldable (foldlM, toList)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Semigroup ((<>))+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Language.Haskell.TH as T++import Pinchot.Types+import Pinchot.Rules++-- | Creates an instance of 'Bifunctor.Bifunctor' for every 'Rule'+-- in the 'Seq' as well as their ancestors.+--+-- This function must be+-- spliced in the same module as the module in which the syntax tree+-- types are created.  This avoids problems with orphan instances.+-- Since ancestors are included, you can get the entire tree of+-- instances that you need by applying this function to a single+-- start symbol.+--+-- Example: "Pinchot.Examples.SyntaxTrees".++bifunctorInstances+  :: Seq (Rule t)+  -> T.DecsQ+bifunctorInstances = traverse f . toList . families+  where+    f rule@(Rule ruleName _ _) = T.instanceD (T.cxt [])+      [t| Bifunctor.Bifunctor $(T.conT (T.mkName ruleName)) |]+      [T.valD (T.varP 'Bifunctor.bimap)+              (T.normalB (bimapExpression "" rule)) []]++-- | Where possible, creates an instance of 'Semigroup.Semigroup'+-- for every 'Rule' in the 'Seq' as well as their ancestors.  Only+-- 'star' and 'plus' rules, as well as rules that through one or+-- more layers of 'wrap' ultimately wrap a 'star' or 'plus' rule,+-- get a 'Semigroup.Semigroup' instance.+--+-- This function must be+-- spliced in the same module as the module in which the syntax tree+-- types are created.  This avoids problems with orphan instances.+-- Since ancestors are included, you can get the entire tree of+-- instances that you need by applying this function to a single+-- start symbol.+--+-- Example: "Pinchot.Examples.SyntaxTrees".++semigroupInstances+  :: Seq (Rule t)+  -> T.DecsQ+semigroupInstances = fmap catMaybes . traverse f . toList . families+  where+    nameT = T.varT $ T.mkName "t"+    nameA = T.varT $ T.mkName "a"+    f rule@(Rule ruleName _ _) = case semigroupExpression "" rule of+      Nothing -> return Nothing+      Just expn -> fmap Just+        $ T.instanceD (T.cxt [])+          [t| Semigroup.Semigroup+            ( $(T.conT (T.mkName ruleName)) $(nameT) $(nameA)) |]+          [T.valD (T.varP '(Semigroup.<>))+                  (T.normalB expn) []]++-- | Where possible, creates an instance of 'Monoid'+-- for every 'Rule' in the 'Seq' as well as their ancestors.  Only+-- 'star' rules, as well as rules that through one or+-- more layers of 'wrap' ultimately wrap a 'star' rule,+-- get a 'Monoid' instance.+--+-- This function must be+-- spliced in the same module as the module in which the syntax tree+-- types are created.  This avoids problems with orphan instances.+-- Since ancestors are included, you can get the entire tree of+-- instances that you need by applying this function to a single+-- start symbol.+--+-- Example: "Pinchot.Examples.SyntaxTrees".+monoidInstances+  :: Seq (Rule t)+  -> T.DecsQ+monoidInstances = fmap catMaybes . traverse f . toList . families+  where+    nameT = T.varT $ T.mkName "t"+    nameA = T.varT $ T.mkName "a"+    f rule@(Rule ruleName _ _)+      = case (semigroupExpression "" rule, memptyExpression "" rule) of+      (Just expAppend, Just expMempty) -> fmap Just+        $ T.instanceD (T.cxt [])+          [t| Monoid ( $( T.conT (T.mkName ruleName) ) $(nameT) $(nameA) ) |]+          [ T.valD (T.varP 'mappend)+                   (T.normalB expAppend) []+          , T.valD (T.varP 'mempty)+                   (T.normalB expMempty) [] ]+      _ -> return Nothing++++-- Creates an expression of type+--+-- (a -> b) -> (c -> d) -> RuleData a c -> RuleData b d+bimapExpression+  :: Qualifier+  -> Rule t+  -> T.ExpQ+bimapExpression qual rule@(Rule ruleName _ _) = do+  fa <- T.newName "fa"+  fb <- T.newName "fb"+  val <- T.newName "val"+  lkpName <- nameMap rule+  letBinds <- bimapLetBinds qual fa fb lkpName rule+  let resultExpn =+        [| $(T.varE $ errLookup ruleName lkpName) $(T.varE val) |]+  T.lamE [T.varP fa, T.varP fb, T.varP val]+    (T.letE letBinds resultExpn)+++bimapLetBinds+  :: Qualifier+  -> T.Name+  -- ^ @(a -> b)@+  -> T.Name+  -- ^ @(c -> d)@+  -> Map RuleName T.Name+  -- ^ Looks up names for other let binds+  -> Rule t+  -> T.Q [T.DecQ]+bimapLetBinds qual fa fb lkp rule+  = traverse (bimapLetBind qual fa fb lkp) . toList . family $ rule++bimapLetBind+  :: Qualifier+  -> T.Name+  -- ^ @(a -> b)@+  -> T.Name+  -- ^ @(c -> d)@+  -> Map RuleName T.Name+  -> Rule t+  -> T.Q T.DecQ+bimapLetBind qual fa fb lkp (Rule name _ ty) = case ty of+  Terminal _ -> terminalBimapLetBind qual fa fb lkp name+  NonTerminal b1 bs -> return $ nonTerminalBimapLetBind qual lkp name+    (b1 : toList bs)+  Wrap (Rule inner _ _) -> wrapBimapLetBind qual lkp name inner+  Record sq -> recordBimapLetBind qual lkp name sq+  Opt (Rule inner _ _) -> optBimapLetBind qual lkp name inner+  Star (Rule inner _ _) -> starBimapLetBind qual lkp name inner+  Plus (Rule inner _ _) -> plusBimapLetBind qual lkp name inner+++terminalBimapLetBind+  :: Qualifier+  -> T.Name+  -> T.Name+  -> Map RuleName T.Name+  -> RuleName+  -> T.Q T.DecQ+terminalBimapLetBind qual fa fb lkp name = do+  val <- T.newName $ "terminalBimapLetBind" ++ name+  let body = T.lamE [T.conP (quald qual name) [T.varP val]]+        [| $(T.conE (quald qual name))+              ( $(T.varE fa) . fst $ $(T.varE val)+              , $(T.varE fb) . snd $ $(T.varE val)+              )+        |]+  return $ T.valD (T.varP (errLookup name lkp)) (T.normalB body) []++nonTerminalBimapLetBind+  :: Qualifier+  -> Map RuleName T.Name+  -> RuleName+  -> [Branch a]+  -> T.DecQ+nonTerminalBimapLetBind qual lkp name branches =+  let mkClause (Branch branchName branches)+        = recordBimapClause qual lkp branchName branches+      clauses = fmap mkClause branches+  in T.funD (errLookup name lkp) clauses++wrapBimapLetBind+  :: Qualifier+  -> Map RuleName T.Name+  -> RuleName+  -> RuleName+  -> T.Q T.DecQ+wrapBimapLetBind qual lkp name inner = do+  val <- T.newName "wrapLetBind"+  let expn = T.lamE [T.conP (quald qual name) [T.varP val]]+        [| $(T.conE (quald qual name))+            ( $(T.varE (errLookup inner lkp)) $(T.varE val) ) |]+  return $ T.valD (T.varP (errLookup name lkp)) (T.normalB expn) []++recordBimapLetBind+  :: Qualifier+  -> Map RuleName T.Name+  -> RuleName+  -> Seq (Rule t)+  -> T.Q T.DecQ+recordBimapLetBind qual lkp name sq = do+  let clause = recordBimapClause qual lkp name sq+  return $ T.funD (errLookup name lkp) [clause]++recordBimapClause+  :: Qualifier+  -> Map RuleName T.Name+  -> RuleName+  -> Seq (Rule t)+  -> T.ClauseQ+recordBimapClause qual lkp name sq = do+  pairs <- traverse (recordBimapLetBindField lkp) . toList $ sq+  let body = foldl f (T.conE (quald qual name)) . fmap snd $ pairs+        where+          f acc expn = [| $(acc) $(expn) |]+  let pats = fmap fst pairs+  T.clause [T.conP (quald qual name) pats] (T.normalB body) []++recordBimapLetBindField+  :: Map RuleName T.Name+  -> Rule t+  -> T.Q (T.PatQ, T.ExpQ)+recordBimapLetBindField lkp (Rule name _ _) = do+  tName <- T.newName $ "recordField" ++ name+  let expn = [| $(T.varE (errLookup name lkp)) $(T.varE tName) |]+  return (T.varP tName, expn)++optBimapLetBind+  :: Qualifier+  -> Map RuleName T.Name+  -> RuleName+  -- ^ Name of this rule+  -> RuleName+  -- ^ Name of inner rule+  -> T.Q T.DecQ+optBimapLetBind qual lkp name inner = do+  val <- T.newName $ "optBimapLetBind" ++ name+  let body = [| $(T.conE (quald qual name)) $ case $(T.varE val) of+                  Nothing -> Nothing+                  Just v -> Just $ $(T.varE (errLookup inner lkp)) v+             |]+  let clause = T.clause [T.conP (quald qual name) [T.varP val]]+        (T.normalB body) []+  return $ T.funD (errLookup name lkp) [clause]++starBimapLetBind+  :: Qualifier+  -> Map RuleName T.Name+  -> RuleName+  -- ^ Name of this rule+  -> RuleName+  -- ^ Name of inner rule+  -> T.Q T.DecQ+starBimapLetBind qual lkp name inner = do+  val <- T.newName $ "starBimapLetBind" ++ name+  let body = [| $(T.conE (quald qual name))+                $ fmap $(T.varE (errLookup inner lkp)) $(T.varE val) |]+  let clause = T.clause [T.conP (quald qual name) [T.varP val]]+        (T.normalB body) []+  return $ T.funD (errLookup name lkp) [clause]++plusBimapLetBind+  :: Qualifier+  -> Map RuleName T.Name+  -> RuleName+  -- ^ Name of this rule+  -> RuleName+  -- ^ Name of inner rule+  -> T.Q T.DecQ+plusBimapLetBind qual lkp name inner = do+  val <- T.newName $ "plusBimapLetBind" ++ name+  let body = [| $(T.conE (quald qual name))+                $ fmap $(T.varE (errLookup inner lkp)) $(T.varE val) |]+  let clause = T.clause [T.conP (quald qual name) [T.varP val]]+        (T.normalB body) []+  return $ T.funD (errLookup name lkp) [clause]+++errLookup+  :: (Ord a, Show a)+  => a+  -> Map a b+  -> b+errLookup k m = case Map.lookup k m of+  Nothing -> error $ "lookup: key not found: " ++ show k+  Just v -> v++-- | Creates a map of all ancestor rule names and a corresponding TH+-- name.+nameMap+  :: Rule t+  -> T.Q (Map RuleName T.Name)+nameMap = foldlM f Map.empty . family+  where+    f acc (Rule ruleName _ _) = do+      thName <- T.newName $ "bindName" ++ ruleName+      return $ Map.insert ruleName thName acc+++-- | If possible, creates an expression of type+--+-- RuleData+--+-- which is a Monoid 'mempty'.+memptyExpression+  :: Qualifier+  -> Rule t+  -> Maybe T.ExpQ+memptyExpression qual rule = do+  ctors <- monoidCtors rule+  return $ wrappedMemptyExpression qual ctors++wrappedMemptyExpression+  :: Qualifier+  -> Seq RuleName+  -> T.ExpQ+wrappedMemptyExpression qual rules = foldr f [| mempty |] rules+  where+    f name acc = [| $(T.conE (quald qual name)) $(acc) |]++-- | If possible, creates an expression of type+--+-- RuleData -> RuleData -> RuleData+--+-- which is a Monoid 'mappend'.+mappendExpression+  :: Qualifier+  -> Rule t+  -> Maybe T.ExpQ+mappendExpression qual rule = do+  ctors <- monoidCtors rule+  return $ wrappedSemigroupExpression 'mappend qual ctors++monoidCtors+  :: Rule t+  -> Maybe (Seq RuleName)+monoidCtors (Rule ruleName _ ty) = case ty of+  Wrap r -> do+    rest <- monoidCtors r+    return $ ruleName `Lens.cons` rest+  Star _ -> Just (Seq.singleton ruleName)+  _ -> Nothing++-- | If possible, creates an expression of type+--+-- RuleData -> RuleData -> RuleData+--+-- which is a Semigroup '<>'.++semigroupExpression+  :: Qualifier+  -> Rule t+  -> Maybe T.ExpQ+semigroupExpression qual rule = do+  ctors <- semigroupCtors rule+  return $ wrappedSemigroupExpression '(<>) qual ctors+++semigroupCtors+  :: Rule t+  -> Maybe (Seq RuleName)+semigroupCtors (Rule ruleName _ ty) = case ty of+  Wrap r -> do+    rest <- semigroupCtors r+    return $ ruleName `Lens.cons` rest+  Plus _ -> Just (Seq.singleton ruleName)+  Star _ -> Just (Seq.singleton ruleName)+  _ -> Nothing++wrappedSemigroupExpression+  :: T.Name+  -- ^ mappend operator+  -> Qualifier+  -> Seq RuleName+  -- ^ Rule names, with the outermost name on the left side of the+  -- 'Seq'.+  -> T.ExpQ+  -- ^ An expression of type+  --+  -- RuleData -> RuleData -> RuleData+  --+  -- It unwraps the two argument types, uses the Semigroup @<>@+  -- operator to combine them, and rewraps the result.+wrappedSemigroupExpression append qual rules = names >>= makeExp+  where+    names = (,) <$> T.newName "x1" <*> T.newName "x2"+    makeExp (x1, x2) = [| \ $(mkPat x1) $(mkPat x2) -> $(mkRes) |]+      where+        mkPat name = foldr f (T.varP name) rules+          where+            f rule acc = T.conP (quald qual rule) [acc]+        mkRes = foldr f+          [| $(T.varE append) $(T.varE x1) $(T.varE x2) |] rules+          where+            f rule acc = T.appE (T.conE (quald qual rule)) acc

@@ -1,9 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Pinchot.SyntaxTree.Optics where -import Data.Coerce (coerce) import Data.Foldable (toList)-import Data.Maybe (catMaybes) import Data.Sequence (Seq) import qualified Control.Lens as Lens import qualified Language.Haskell.TH as T@@ -98,7 +96,6 @@   return [e1, e2]   where     anyType = T.varT (T.mkName "a")-    charType = T.varT (T.mkName "t")     prismName = T.varP (T.mkName ('_' : nm))     fetchPat = T.conP (quald qual nm) [T.varP (T.mkName "_x")]     fetchName = T.varE (T.mkName "_x")

@@ -9,7 +9,6 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Language.Haskell.TH as T-import qualified Language.Haskell.TH.Syntax as Syntax  import Pinchot.NonEmpty (NonEmpty(NonEmpty)) import qualified Pinchot.NonEmpty as NonEmpty@@ -40,16 +39,12 @@   -- ^ Qualifier for the module containing the data types created   -- from the 'Rule's  -  -> T.Name-  -- ^ Name of terminal type.  Typically you will get this through-  -- the Template Haskell quoting mechanism, such as @''Char@.-   -> Seq (Rule t)   -> T.Q [T.Dec] -terminalizers qual termType+terminalizers qual   = fmap concat-  . traverse (terminalizer qual termType)+  . traverse (terminalizer qual)   . toList   . families @@ -76,14 +71,10 @@   -- ^ Qualifier for the module containing the data types created   -- from the 'Rule's  -  -> T.Name-  -- ^ Name of terminal type.  Typically you will get this through-  -- the Template Haskell quoting mechanism, such as @''Char@.-   -> Rule t   -> T.Q [T.Dec] -terminalizer qual termType rule@(Rule nm _ _) = sequence [sig, expn]+terminalizer qual rule@(Rule nm _ _) = sequence [sig, expn]   where     declName = "t'" ++ nm     anyType = T.varT (T.mkName "a")@@ -233,7 +224,6 @@      | otherwise -> do         x <- T.newName "x"-        let pat = T.conP (quald qual nm) [T.varP x]         [| let getTermSeq = $(T.varE (lookupName lkp inner))                getTerms (NonEmpty e1 es) = getTermSeq e1                 `mappend` (join (fmap getTermSeq es))

@@ -0,0 +1,15 @@+-- | A compatibility shim so Pinchot can work with versions of the+-- template-haskell library both before and after version 2.11.+-- The .cabal file is set up so this version of this module is used+-- for 2.10 versions of template-haskell.+module Pinchot.Internal.TemplateHaskellShim where++import qualified Language.Haskell.TH as T++newtypeD+  :: T.CxtQ -> T.Name -> [T.TyVarBndr] -> T.ConQ -> [T.Name] -> T.DecQ+newtypeD = T.newtypeD++dataD+  :: T.CxtQ -> T.Name -> [T.TyVarBndr] -> [T.ConQ] -> [T.Name] -> T.DecQ+dataD = T.dataD

@@ -3,16 +3,16 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs--- Generated on: 2016-04-10 09:37:56.35801 EDT--- Cartel library version: 0.14.2.8+-- Generated on: 2016-04-30 09:55:17.798604 EDT+-- Cartel library version: 0.16.0.0  name: pinchot-version: 0.16.0.0+version: 0.18.0.0 cabal-version: >= 1.14 license: BSD3 license-file: LICENSE build-type: Simple-copyright: 2015 Omari Norman+copyright: 2015-2016 Omari Norman author: Omari Norman maintainer: omari@smileystation.com stability: Experimental@@ -48,6 +48,7 @@     Pinchot.RecursiveDo     Pinchot.Rules     Pinchot.SyntaxTree+    Pinchot.SyntaxTree.Instancer     Pinchot.SyntaxTree.Optics     Pinchot.SyntaxTree.Wrappers     Pinchot.Terminalize@@ -56,10 +57,22 @@       base >= 4.8.0.0 && < 5     , containers >= 0.5.6.2     , transformers >= 0.4.2.0-    , template-haskell >= 2.10     , Earley >= 0.11.0.1     , lens >= 4.13     , ListLike >= 4.2.1+    , semigroups >= 0.18.1+  if flag(oldTemplateHaskell)+    build-depends:+        template-haskell >= 2.10 && < 2.11+    hs-source-dirs:+      oldTemplateHaskell+  else+    build-depends:+        template-haskell >= 2.11+    hs-source-dirs:+      newTemplateHaskell+  other-modules:+    Pinchot.Internal.TemplateHaskellShim   other-extensions:     TemplateHaskell   default-language: Haskell2010@@ -91,6 +104,7 @@       Pinchot.RecursiveDo       Pinchot.Rules       Pinchot.SyntaxTree+      Pinchot.SyntaxTree.Instancer       Pinchot.SyntaxTree.Optics       Pinchot.SyntaxTree.Wrappers       Pinchot.Terminalize@@ -101,10 +115,22 @@         base >= 4.8.0.0 && < 5       , containers >= 0.5.6.2       , transformers >= 0.4.2.0-      , template-haskell >= 2.10       , Earley >= 0.11.0.1       , lens >= 4.13       , ListLike >= 4.2.1+      , semigroups >= 0.18.1+    if flag(oldTemplateHaskell)+      build-depends:+          template-haskell >= 2.10 && < 2.11+      hs-source-dirs:+        oldTemplateHaskell+    else+      build-depends:+          template-haskell >= 2.11+      hs-source-dirs:+        newTemplateHaskell+    other-modules:+      Pinchot.Internal.TemplateHaskellShim     other-extensions:       TemplateHaskell     default-language: Haskell2010@@ -112,6 +138,11 @@       lib   else     buildable: False++Flag oldTemplateHaskell+  description: Use version of Template Haskell before 2.11+  default: False+  manual: False  Flag executables   description: Build executables