pinchot 0.22.0.0 → 0.24.0.0

raw patch · 19 files changed

+844/−913 lines, 19 filesdep −ListLikedep −non-empty-sequencePVP ok

version bump matches the API change (PVP)

Dependencies removed: ListLike, non-empty-sequence

API changes (from Hackage documentation)

Files

• lib/Pinchot.hs +3/−9
• lib/Pinchot/Earley.hs +131/−140
• lib/Pinchot/Examples/Newman.hs +10/−13
• lib/Pinchot/Examples/Postal.hs +12/−10
• lib/Pinchot/Examples/SyntaxTrees.hs +4/−1
• lib/Pinchot/Examples/Terminalize.hs +2/−2
• lib/Pinchot/Intervals.hs +0/−258
• lib/Pinchot/Locator.hs +12/−25
• lib/Pinchot/Names.hs +134/−0
• lib/Pinchot/Pretty.hs +9/−18
• lib/Pinchot/RecursiveDo.hs +15/−17
• lib/Pinchot/Rules.hs +35/−30
• lib/Pinchot/SyntaxTree.hs +24/−33
• lib/Pinchot/SyntaxTree/Instancer.hs +72/−60
• lib/Pinchot/SyntaxTree/Optics.hs +249/−130
• lib/Pinchot/SyntaxTree/Wrappers.hs +32/−33
• lib/Pinchot/Terminalize.hs +63/−48
• lib/Pinchot/Types.hs +31/−74
• pinchot.cabal +6/−12

@@ -40,15 +40,9 @@  -} module Pinchot-  ( -- * Intervals-    Intervals-  , include-  , exclude-  , solo-  , pariah-+  (   -- * Production rules-  , RuleName+    RuleName   , Rule   , BranchName   , terminal@@ -102,7 +96,7 @@  import Pinchot.Earley import Pinchot.Locator-import Pinchot.Intervals+import Pinchot.Names import Pinchot.Rules import Pinchot.SyntaxTree import Pinchot.SyntaxTree.Instancer

@@ -4,137 +4,135 @@  module Pinchot.Earley where +import Pinchot.Names import Pinchot.RecursiveDo import Pinchot.Rules import Pinchot.Types-import Pinchot.Intervals  import Control.Applicative ((<|>), liftA2) import Data.Data (Data)-import Data.Foldable (toList)-import Data.Sequence.NonEmpty (NonEmptySeq(NonEmptySeq))-import qualified Data.Sequence.NonEmpty as NE-import Data.Sequence ((<|), viewl, ViewL(EmptyL, (:<)), Seq)-import qualified Data.Sequence as Seq+import Data.Foldable (foldlM)+import Data.List.NonEmpty (NonEmpty((:|))) import qualified Language.Haskell.TH as T import qualified Language.Haskell.TH.Syntax as Syntax import qualified Text.Earley  earleyTerm   :: Eq t-  => NonEmptySeq t-  -> Text.Earley.Prod r e (t, a) (NonEmptySeq (t, a))-earleyTerm sq = NonEmptySeq <$> parseHead <*> parseRest+  => NonEmpty t+  -> Text.Earley.Prod r e (t, a) (NonEmpty (t, a))+earleyTerm (fore :| aft) = (:|) <$> parseHead <*> parseRest   where-    parseHead = parse . NE._fore $ sq-    parseRest = foldr (liftA2 (<|) . parse) (pure Seq.empty) (NE._aft sq)+    parseHead = parse fore+    parseRest = foldr (liftA2 (:) . parse) (pure []) aft     parse t = Text.Earley.satisfy ((== t) . fst) --- | Creates a list of pairs.  Each list represents a statement in+branchToParser+  :: Syntax.Lift t+  => String+  -- ^ Module prefix+  -> Branch t+  -> Namer T.ExpQ+branchToParser prefix (Branch name rules) = do+  case rules of+    [] -> return [| pure $constructor |]+    (Rule rule1 _ _) : xs -> do+      rule1Name <- getName rule1+      let z = [| $constructor <$> $(T.varE rule1Name) |]+          f soFar (Rule rule2 _ _) = do+            rule2Name <- getName rule2+            return [| $soFar <*> $(T.varE rule2Name) |]+      foldlM f z xs+  where+    constructor = do+      ctorName <- lookupValueName (quald prefix name)+      T.conE ctorName++-- | Creates a list of pairs.  Each pair represents a statement in -- @do@ notation.  The first element of the pair is the name of the -- variable to which to bind the result of the expression, which is -- the second element of the pair.+ ruleToParser   :: (Syntax.Lift t, Data t)   => String   -- ^ Module prefix   -> Rule t-  -> [(T.Name, T.ExpQ)]-ruleToParser prefix (Rule nm mayDescription rt) = case rt of+  -> Namer [(T.Name, T.ExpQ)]+ruleToParser prefix (Rule nm mayDescription rt) = do+  bindName <- getName nm+  let desc = maybe nm id mayDescription+      makeRule expression = (bindName,+        [|Text.Earley.rule ($expression Text.Earley.<?> desc)|])+      constructor = do+        ctorName <- lookupValueName (quald prefix nm)+        T.conE ctorName+      wrapper wrapRule = [|fmap $constructor $(T.varE wrapRule) |]+  case rt of+    Terminal (Predicate pdct) -> return [makeRule expression]+      where+        expression = do+          ctorName <- lookupValueName (quald prefix nm)+          [| let f (c, a)+                  | $(fmap T.unType pdct) c = Just+                      ($(T.conE ctorName) (c, a))+                  | otherwise = Nothing+            in Text.Earley.terminal f |] -  Terminal ivls -> [makeRule expression]-    where-      expression =-        [| let f (c, a)-                | inIntervals ivls c = Just-                    ($(T.conE (quald prefix nm)) (c, a))-                | otherwise = Nothing-           in Text.Earley.terminal f |]+    NonTerminal (b1 :| bs) -> do+      let addBranch tree branch = do+            branchParserExpn <- branchToParser prefix branch+            return [| $tree <|> $branchParserExpn |]+      branch1 <- branchToParser prefix b1+      expression <- foldlM addBranch branch1 bs+      return [makeRule expression] -  NonTerminal (NE.NonEmptySeq b1 bs) -> [makeRule expression]-    where-      expression = foldl addBranch (branchToParser prefix b1) bs-        where-          addBranch tree branch =-            [| $tree <|> $(branchToParser prefix branch) |]+    Wrap (Rule innerNm _ _) -> do+      innerName <- getName innerNm+      let expression = [| fmap $constructor $(T.varE innerName) |]+      return [makeRule expression] -  Wrap (Rule innerNm _ _) -> [makeRule expression]-    where-      expression = [|fmap $constructor $(T.varE (localRuleName innerNm)) |]+    Record sq -> do+      expression <- case sq of+        [] -> return [| pure $constructor |]+        Rule r1 _ _ : restFields -> do+          r1Name <- getName r1+          let fstField = [| $constructor <$> $(T.varE r1Name) |]+              addField soFar (Rule r _ _) = do+                rName <- getName r+                return [| $soFar <*> $(T.varE rName) |]+          foldlM addField fstField restFields+      return [makeRule expression] -  Record sq -> [makeRule expression]-    where-      expression = case viewl sq of-        EmptyL -> [| pure $constructor |]-        Rule r1 _ _ :< restFields -> foldl addField fstField restFields-          where-            fstField = [| $constructor <$> $(T.varE (localRuleName r1)) |]-            addField soFar (Rule r _ _)-              = [| $soFar <*> $(T.varE (localRuleName r)) |]-    -  Opt (Rule innerNm _ _) -> [makeRule expression]-    where-      expression = [| fmap $constructor (pure Nothing <|> $(just)) |]-        where-          just = [| fmap Just $(T.varE (localRuleName innerNm)) |]+    Opt (Rule innerNm _ _) -> do+      innerName <- getName innerNm+      let just = [| fmap Just $(T.varE innerName) |]+          expression = [| fmap $constructor (pure Nothing <|> $(just)) |]+      return [makeRule expression] -  Star (Rule innerNm _ _) -> [nestRule, makeRule (wrapper helper)]-    where-      nestRule = (helper, ([|Text.Earley.rule|] `T.appE` parseSeq))-        where-          parseSeq = T.uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq-            where-              pSeq = [|liftA2 (<|)-                $(T.varE (localRuleName innerNm)) $(T.varE helper) |]+    Star (Rule innerNm _ _) -> do+      innerName <- getName innerNm+      helperName <- namerNewName+      let pList = [| liftA2 (:) $(T.varE innerName) $(T.varE helperName) |]+          pChoose = T.uInfixE [|pure []|] [|(<|>)|] pList+          nestRule = (helperName, ([|Text.Earley.rule|] `T.appE` pChoose))+      return [nestRule, makeRule (wrapper helperName)] -  Plus (Rule innerNm _ _) -> [nestRule, makeRule topExpn]-    where-      nestRule = (helper, [|Text.Earley.rule $(parseSeq)|])-        where-          parseSeq = [| pure Seq.empty <|> $pSeq |]-            where-              pSeq = [| (<|) <$> $(T.varE (localRuleName innerNm))-                             <*> $(T.varE helper) |]-      topExpn = [| $constructor <$>-        ( NonEmptySeq <$> $(T.varE (localRuleName innerNm))-                   <*> $(T.varE helper)) |]+    Plus (Rule innerNm _ _) -> do+      innerName <- getName innerNm+      helperName <- namerNewName+      let pList = [| (:) <$> $(T.varE innerName) <*> $(T.varE helperName) |]+          pChoose = [| pure [] <|> $pList |]+          nestRule = (helperName, [|Text.Earley.rule $pChoose |])+          topExpn = [| $constructor <$>+            ( (:|) <$> $(T.varE innerName) <*> $(T.varE helperName)) |]+      return [nestRule, makeRule topExpn] -  Series neSeq -> [makeRule expression]-    where-      expression = [| fmap $constructor $-        earleyTerm $(Syntax.liftData neSeq) |]+    Series neSeq -> do+      let expn = [| fmap $constructor $ earleyTerm $(Syntax.liftData neSeq) |]+      return [makeRule expn]  -  where-    makeRule expression = (localRuleName nm,-      [|Text.Earley.rule ($expression Text.Earley.<?> $(textToExp desc))|])-    desc = maybe nm id mayDescription-    textToExp txt = [| $(Syntax.lift txt) |]-    constructor = T.conE (quald prefix nm)-    wrapper wrapRule = [|fmap $constructor $(T.varE wrapRule) |]-    helper = helperName nm--localRuleName :: String -> T.Name-localRuleName suffix = T.mkName ("_rule'" ++ suffix)--helperName :: String -> T.Name-helperName suffix = T.mkName ("_helper'" ++ suffix)--branchToParser-  :: Syntax.Lift t-  => String-  -- ^ Module prefix-  -> Branch t-  -> T.ExpQ-branchToParser prefix (Branch name rules) = case viewl rules of-  EmptyL -> [| pure $constructor |]-  (Rule rule1 _ _) :< xs -> foldl f z xs-    where-      z = [| $constructor <$> $(T.varE (localRuleName rule1)) |]-      f soFar (Rule rule2 _ _) = [| $soFar <*> $(T.varE (localRuleName rule2)) |]-  where-    constructor = T.conE (quald prefix name)- -- | Creates an expression that has type -- -- 'Text.Earley.Grammar' r (Prod r String (c, a) (p c a))@@ -153,10 +151,13 @@   -> Rule t   -- ^ Create a grammar for this 'Rule'   -> T.Q T.Exp-earleyGrammarFromRule prefix r@(Rule top _ _) = recursiveDo binds final-  where-    binds = concatMap (ruleToParser prefix) . toList . family $ r-    final = [| return $(T.varE $ localRuleName top) |]+earleyGrammarFromRule prefix r@(Rule top _ _) = do+  (binds, topName) <- runNamer $ do+    bnds <- fmap concat . sequence . fmap (ruleToParser prefix) . family $ r+    topN <- getName top+    return (bnds, topN)+  let final = [| return $(T.varE topName) |]+  recursiveDo binds final  -- | Creates a record data type that holds a value of type --@@ -181,7 +182,7 @@   :: Qualifier   -- ^ Qualifier for data types corresponding to those created from   -- the 'Rule's-  -> Seq (Rule t)+  -> [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.   -> T.DecsQ@@ -193,28 +194,20 @@   -- where @NAME@ is the name of the type.  Don't count on these   -- records being in any particular order. allRulesRecord prefix ruleSeq-  = sequence [T.dataD (return []) (T.mkName nameStr)+  = sequence [T.dataD (return []) productions                       tys Nothing [con] (return [])]   where-    nameStr = "Productions"-    tys = [T.PlainTV (T.mkName "r"), T.PlainTV (T.mkName "t"),-      T.PlainTV (T.mkName "a")]-    con = T.recC (T.mkName nameStr)-        (fmap mkRecord . toList . families $ ruleSeq)-    mkRecord (Rule ruleNm _ _) = T.varBangType recName st+    tys = [tyVarBndrR, tyVarBndrT, tyVarBndrA]+    con = T.recC productions+        (fmap mkRecord . families $ ruleSeq)+    mkRecord (Rule ruleNm _ _) = T.varBangType (recordName ruleNm) st       where-        recName = T.mkName ("a'" ++ ruleNm)         st = T.bangType (T.bang T.noSourceUnpackedness T.noSourceStrictness) ty           where-            ty = [t| Text.Earley.Prod $(T.varT (T.mkName "r"))-                      String-                      ( $(T.varT (T.mkName "t")), $(T.varT (T.mkName "a")))-                      ( $(T.conT (T.mkName nameWithPrefix))-                            $(T.varT (T.mkName "t"))-                            $(T.varT (T.mkName "a"))) |]-            nameWithPrefix = case prefix of-              [] -> ruleNm-              _ -> prefix ++ '.' : ruleNm+            ty = do+              ctorName <- lookupTypeName (quald prefix ruleNm)+              [t| Text.Earley.Prod $typeR String ($typeT, $typeA)+                      ( $(T.conT ctorName) $typeT $typeA) |]  -- | Creates a 'Text.Earley.Grammar' that contains a -- 'Text.Earley.Prod' for every given 'Rule' and its ancestors.@@ -229,9 +222,9 @@   -> Qualifier   -- ^ Qualifier for the type created with 'allRulesRecord' -  -> Seq (Rule t)+  -> [Rule t]   -- ^ Creates an Earley grammar that contains a 'Text.Earley.Prod'-  -- for each 'Rule' in this 'Seq', as well as all the ancestors of+  -- for each 'Rule' in this list, as well as all the ancestors of   -- these 'Rule's.    -> T.ExpQ@@ -243,21 +236,19 @@   -- any additional information about each token (often   -- 'Pinchot.Loc'). earleyProduct pfxRule pfxRec ruleSeq = do-  let binds = concatMap (ruleToParser pfxRule)-        . toList . families $ ruleSeq-      final = [| return-        $(T.recConE (T.mkName rulesRecName)-                    (fmap mkRec . toList . families $ ruleSeq)) |]-        -  recursiveDo binds final-  where-    rulesRecName-      | null pfxRec = "Productions"-      | otherwise = pfxRec ++ ".Productions"-    mkRec (Rule n _ _) = return (T.mkName recName, recVal)-      where-        recName-          | null pfxRec = "a'" ++ n-          | otherwise = pfxRec ++ ".a'" ++ n-        recVal = T.VarE . localRuleName $ n+  (binds, topName) <- runNamer $ do+    let fams = families ruleSeq+    bnds <- fmap concat . sequence . fmap (ruleToParser pfxRule) $ fams+    let allRuleNames = fmap _ruleName fams+    allRuleBindNames <- traverse getName allRuleNames+    let mkRec ruleName bindName = (qualRecordName pfxRec ruleName, T.VarE bindName)+        ruleBindNamePairs = zipWith mkRec allRuleNames allRuleBindNames+        convertPair (str, expn) = do+          nm <- lookupValueName str+          return (nm, expn)+        final = do+          recName <- lookupValueName (quald pfxRec productionsStr)+          [| return $(T.recConE recName (fmap convertPair ruleBindNamePairs)) |]+    return (bnds, final)+  recursiveDo binds topName 

@@ -13,12 +13,9 @@ import Pinchot.Examples.RulesToOptics  import qualified Control.Lens as Lens-import Data.Foldable (toList) import Data.List (intersperse)-import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import Data.Sequence.NonEmpty (NonEmptySeq)-import qualified Data.Sequence.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty, toList)+import qualified Data.List.NonEmpty as NE import qualified Text.Earley as Earley import qualified Text.Show.Pretty as Pretty @@ -30,9 +27,9 @@  -- | Labels a single field, where the field may or may not appear in -- a parsed result.-labelOpt :: String -> Seq (Char, Loc) -> String+labelOpt :: String -> [(Char, Loc)] -> String labelOpt l sq-  = l ++ ": " ++ show (toList . fmap fst $ sq)+  = l ++ ": " ++ show (fmap fst $ sq)   ++ " " ++ loc ++ "\n"   where     loc = case Lens.uncons sq of@@ -41,12 +38,12 @@  -- | Labels a single field, where the field will always appear in a -- parsed result.-labelNE :: String -> NonEmptySeq (Char, Loc) -> String+labelNE :: String -> NonEmpty (Char, Loc) -> String labelNE l sq   = l ++ ": " ++ show (toList . fmap fst $ sq)   ++ " " ++ loc ++ "\n"   where-    loc = labelLoc . snd . NE._fore $ sq+    loc = labelLoc . snd . NE.head $ sq  -- | Formats a single 'Address' for nice on-screen display. showAddress :: Address Char Loc -> String@@ -60,7 +57,7 @@           . _r'Address'1'StreetLine $ a          pre = labelOpt "Direction prefix"-          . maybe Seq.empty NE.nonEmptySeqToSeq+          . maybe [] NE.toList           . Lens.preview (r'Address'1'StreetLine                           . r'StreetLine'2'DirectionSpace'Opt                           . Lens._Wrapped'@@ -76,7 +73,7 @@           $ a          suf = labelOpt "Street suffix"-          . maybe Seq.empty NE.nonEmptySeqToSeq+          . maybe [] NE.toList           . Lens.preview (r'Address'1'StreetLine                           . r'StreetLine'4'SpaceSuffix'Opt                           . Lens._Wrapped'@@ -107,7 +104,7 @@ -- | Formats successful 'Address' parses and the 'Earley.Report' for -- nice on-screen display. showParseResult-  :: ([Address Char Loc], Earley.Report String (Seq (Char, Loc)))+  :: ([Address Char Loc], Earley.Report String [(Char, Loc)])   -> String showParseResult (addresses, report) = addresses' ++ "\n" ++ report'   where@@ -115,7 +112,7 @@       . concat . intersperse "---\n" . map showAddress       $ addresses     report' = ("Earley report:\n\n" ++) . show-      $ report { Earley.unconsumed = toList . fmap fst+      $ report { Earley.unconsumed = fmap fst       . Earley.unconsumed $ report }  -- | Parse an address and print the resulting report.  Good for use

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}  -- | This module contains a context-free grammar for U.S. postal@@ -12,22 +13,23 @@ module Pinchot.Examples.Postal where  import Pinchot-import Data.Monoid ((<>)) -rDigit = terminal "Digit" (include '0' '9') <?> "digit from 0 to 9"+rDigit = terminal "Digit" [|| \x -> x >= '0' && x <= '9' ||]+  <?> "digit from 0 to 9"  rDigits = plus rDigit -rLetter = terminal "Letter" (include 'a' 'z' <> include 'A' 'Z')+rLetter = terminal "Letter" [|| \x -> (x >= 'a' && x <= 'z')+                                   || (x >= 'A' && x <= 'Z') ||]   <?> "letter from A to Z" -rNorth = terminal "North" (solo 'N')+rNorth = terminal "North" [|| (== 'N') ||] -rSouth = terminal "South" (solo 'S')+rSouth = terminal "South" [|| (== 'S') ||] -rEast = terminal "East" (solo 'E')+rEast = terminal "East" [|| (== 'E') ||] -rWest = terminal "West" (solo 'W')+rWest = terminal "West" [|| (== 'W') ||]  rNE = series "NE" "NE" @@ -50,11 +52,11 @@  rSuffix = union "Suffix" [rStreet, rAvenue, rWay, rBoulevard] -rSpace = terminal "Space" (solo ' ')+rSpace = terminal "Space" [|| (== ' ') ||] -rComma = terminal "Comma" (solo ',')+rComma = terminal "Comma" [|| (== ',') ||] -rNewline = terminal "Newline" (solo '\n')+rNewline = terminal "Newline" [|| (== '\n') ||]  rCommaSpace = record "CommaSpace" [rComma, rSpace] 

@@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-}  -- The following extension is required only for the splice of Lens wrapped -- instances in 'wrappedInstances'@@ -13,13 +14,15 @@ -- generate them. module Pinchot.Examples.SyntaxTrees where +import GHC.Generics (Generic)+ import Pinchot import Pinchot.Examples.Postal  -- This generates the data types corresponding to the 'rAddress' -- 'Rule', as well as all the ancestors of that 'Rule'. $(syntaxTrees-  [''Eq, ''Ord, ''Show, ''Foldable, ''Traversable, ''Functor]+  [''Eq, ''Ord, ''Show, ''Foldable, ''Traversable, ''Functor, ''Generic]   [rAddress])  -- This generates intances of the Lens Wrapped typeclass.

@@ -6,13 +6,13 @@ -- that were used to create it. module Pinchot.Examples.Terminalize where -import Data.Sequence.NonEmpty (NonEmptySeq)+import Data.List.NonEmpty (NonEmpty)  import Pinchot import Pinchot.Examples.Postal import qualified Pinchot.Examples.SyntaxTrees as SyntaxTrees -terminalizeAddress :: SyntaxTrees.Address t a -> NonEmptySeq (t, a)+terminalizeAddress :: SyntaxTrees.Address t a -> NonEmpty (t, a) terminalizeAddress = $(terminalizeRuleExp "SyntaxTrees" rAddress)  $(terminalizers "SyntaxTrees" [rAddress])

@@ -1,258 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | Intervals describe terminal symbols.  Ordinarily you will not--- need to use this module, as "Pinchot" re-exports the things you--- usually need.-module Pinchot.Intervals where--import qualified Control.Lens as Lens-import Control.Monad (join)-import Data.Data (Data)-import Data.Monoid ((<>))-import Data.Ord (comparing)-import Data.Sequence (Seq, ViewL(EmptyL, (:<)), viewl, (<|))-import qualified Data.Sequence as Seq-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import Text.Show.Pretty (PrettyVal)-import qualified Text.Show.Pretty as Pretty--import Pinchot.Pretty---- | Groups of terminals.  Create an 'Intervals' using 'include',--- 'exclude', 'solo' and 'pariah'.  Combine 'Intervals' using--- 'mappend', which will combine both the included and excluded--- terminal symbols from each operand.-data Intervals a = Intervals-  { _included :: Seq (a, a)-  -- ^ Each pair @(a, b)@ is an inclusive range of terminal symbols,-  -- in order.  For instance, @('a', 'c')@ includes the characters-  -- @'a'@, @'b'@, and @'c'@.  The 'included' sequence contains all-  -- terminals that are included in the 'Intervals', except for those-  -- that are 'excluded'.-  , _excluded :: Seq (a, a)-  -- ^ Each symbol in 'excluded' is not in the 'Intervals', even if-  -- the symbol is 'included'.-  } deriving (Eq, Ord, Show, Data)--Lens.makeLenses ''Intervals--instance PrettyVal a => PrettyVal (Intervals a) where-  prettyVal (Intervals inc exc)-    = Pretty.Rec "Pinchot.Intervals.Intervals"-      [ ("_included", prettySeq Pretty.prettyVal inc)-      , ("_excluded", prettySeq Pretty.prettyVal exc)-      ]--instance Functor Intervals where-  fmap f (Intervals a b) = Intervals (fmap g a) (fmap g b)-    where-      g (x, y) = (f x, f y)--instance Monoid (Intervals a) where-  mempty = Intervals mempty mempty-  (Intervals x1 y1) `mappend` (Intervals x2 y2)-    = Intervals (x1 <> x2) (y1 <> y2)---- | Include a range of symbols in the 'Intervals'.  For instance, to--- include the characters @'a'@, @'b'@, and @'c'@, use @include 'a'--- 'c'@.  Example: 'Pinchot.Examples.Postal.rLetter'.-include :: a -> a -> Intervals a-include l h = Intervals [(l, h)] []---- | Exclude a range of symbols in the 'Intervals'.  Each symbol that--- is 'exclude'd is not included in the 'Intervals', even if it is--- also 'include'd.-exclude :: a -> a -> Intervals a-exclude l h = Intervals [] [(l, h)]---- | Include a single symbol.  Example:--- 'Pinchot.Examples.Postal.rNorth'.-solo :: a -> Intervals a-solo x = Intervals [(x, x)] []---- | Exclude a single symbol.-pariah :: a -> Intervals a-pariah x = Intervals [] [(x, x)]---- | Left endpoint.-endLeft :: Ord a => (a, a) -> a-endLeft (a, b) = min a b---- | Right endpoint.-endRight :: Ord a => (a, a) -> a-endRight (a, b) = max a b---- | Is this symbol included in the interval?-inInterval :: Ord a => a -> (a, a) -> Bool-inInterval x i = x >= endLeft i && x <= endRight i---- | Enumerate all members of an interval.-members :: (Ord a, Enum a) => (a, a) -> Seq a-members i = Seq.fromList [endLeft i .. endRight i]---- | Sort a sequence of intervals.-sortIntervalSeq :: Ord a => Seq (a, a) -> Seq (a, a)-sortIntervalSeq = Seq.sortBy (comparing endLeft <> comparing endRight)---- | Arrange an interval so the lower bound is first in the pair.-standardizeInterval :: Ord a => (a, a) -> (a, a)-standardizeInterval (a, b) = (min a b, max a b)---- | Sorts the intervals using 'sortIntervalSeq' and presents them in a--- regular order using 'flatten'.  The function @standardizeIntervalSeq a@ has--- the following properties, where @b@ is the result:------ @--- 'uniqueMembers' a == 'uniqueMembers' b------ let go [] = True---     go (_:[]) = True---     go (x:y:xs)---          | 'endRight' x < 'endLeft' y---              && 'endRight' x < pred ('endLeft' x)---              = go (y:xs)---          | otherwise = False--- in go b--- @------ The second property means that adjacent intervals in the list must--- be separated by at least one point on the number line.--standardizeIntervalSeq :: (Ord a, Enum a) => Seq (a, a) -> Seq (a, a)-standardizeIntervalSeq = flattenIntervalSeq . sortIntervalSeq---- | Presents the intervals in a standard order, as described in--- 'standardizeIntervalSeq'.  If the input has already been sorted with--- 'sortIntervalSeq', the same properties for 'standardizeIntervalSeq' hold for--- this function.  Otherwise, its properties are undefined.-flattenIntervalSeq :: (Ord a, Enum a) => Seq (a, a) -> Seq (a, a)-flattenIntervalSeq = fmap standardizeInterval . go Nothing-  where-    go mayCurr sq = case (mayCurr, viewl sq) of-      (Nothing, EmptyL) -> []-      (Just i, EmptyL) -> [i]-      (Nothing, x :< xs) -> go (Just x) xs-      (Just curr, x :< xs)-        | endRight curr < endLeft x-            && endRight curr < pred (endLeft x) -> curr <| go (Just x) xs-        | otherwise -> go (Just (endLeft curr,-            max (endRight curr) (endRight x))) xs---{- |-Removes excluded members from a list of 'Interval'.  The-following properties hold:--@--removeProperties-  :: (Ord a, Enum a)-  => Seq (a, a)-  -> Seq (a, a)-  -> [Bool]-removeProperties inc exc =-- let r = removeExcludes inc exc-     allExcluded = concatMap members exc-     allIncluded = concatMap members inc-     allResults = concatMap members r- in [-   -- intervals remain in original order-   allResults == filter (not . (\`elem\` allExcluded)) allIncluded-- -- Every resulting member was a member of the original include list- , all (\`elem\` allIncluded) allResults-- -- No resulting member is in the exclude list- , all (not . (\`elem\` allExcluded)) allResults-- -- Every included member that is not in the exclude list is- -- in the result- , all (\x -> x \`elem\` allExcluded || x \`elem\` allResults)-       allIncluded-- ]-@---}-removeExcludes-  :: (Ord a, Enum a)-  => Seq (a, a)-  -- ^ Included intervals (not necessarily sorted)-  -> Seq (a, a)-  -- ^ Excluded intervals (not necessarily sorted)-  -> Seq (a, a)-removeExcludes inc = foldr remover inc--remover-  :: (Ord a, Enum a)-  => (a, a)-  -- ^ Remove this interval-  -> Seq (a, a)-  -- ^ From this sequence of intervals-  -> Seq (a, a)-remover ivl = join . fmap squash . fmap (removeInterval ivl)-  where-    squash (Nothing, Nothing) = Seq.empty-    squash (Just x, Nothing) = Seq.singleton x-    squash (Nothing, Just x) = Seq.singleton x-    squash (Just x, Just y) = x <| y <| Seq.empty---- | Removes a single interval from a single other interval.  Returns--- a sequence of intervals, which always-removeInterval-  :: (Ord a, Enum a)-  => (a, a)-  -- ^ Remove this interval-  -> (a, a)-  -- ^ From this interval-  -> (Maybe (a, a), Maybe (a, a))-removeInterval ivl oldIvl = (onLeft, onRight)-  where-    onLeft-      | endLeft ivl > endLeft oldIvl =-          Just ( endLeft oldIvl-               , min (pred (endLeft ivl)) (endRight oldIvl))-      | otherwise = Nothing-    onRight-      | endRight ivl < endRight oldIvl =-          Just ( max (succ (endRight ivl)) (endLeft oldIvl)-               , endRight oldIvl)-      | otherwise = Nothing---- | Runs 'standardizeIntervalSeq' on the 'included' and 'excluded'--- intervals.-standardizeIntervals-  :: (Ord a, Enum a)-  => Intervals a-  -> Intervals a-standardizeIntervals (Intervals i e)-  = Intervals (standardizeIntervalSeq i) (standardizeIntervalSeq e)---- | Sorts the intervals using 'standardizeIntervalSeq', and then removes the--- excludes with 'removeExcludes'.-splitIntervals-  :: (Ord a, Enum a)-  => Intervals a-  -> Seq (a, a)-splitIntervals (Intervals is es)-  = removeExcludes (standardizeIntervalSeq is) es---- | 'True' if the given element is a member of the 'Intervals'.-inIntervals :: (Enum a, Ord a) => Intervals a -> a -> Bool-inIntervals ivls a = any (inInterval a) . splitIntervals $ ivls--liftSeq :: Lift a => Seq a -> ExpQ-liftSeq sq = case viewl sq of-  EmptyL -> varE 'Seq.empty-  x :< xs -> uInfixE (lift x) (varE '(<|)) (liftSeq xs)--instance Lift a => Lift (Intervals a) where-  lift (Intervals inc exc) = [| Intervals $sqInc $sqExc |]-    where-      sqInc = liftSeq inc-      sqExc = liftSeq exc

@@ -6,9 +6,7 @@  import Pinchot.Types -import qualified Data.ListLike as ListLike-import Data.Sequence (Seq, (|>))-import qualified Data.Sequence as Seq+import Data.List (mapAccumL) import qualified Text.Earley as Earley  -- | Advances the location for 'Char' values.  Tabs advance to the@@ -21,36 +19,25 @@   | c == '\t' = Loc lin (col + 8 - ((col - 1) `mod` 8)) (pos + 1)   | otherwise = Loc lin (col + 1) (pos + 1) --- | Takes any ListLike value based on 'Char' (@Seq@, @Text@,--- @String@, etc.) and creates a 'Seq' which pairs each 'Char' with--- its location.  Example: 'locatedFullParses'.-locations-  :: ListLike.FoldableLL full Char-  => full-  -> Seq (Char, Loc)-locations = fst . ListLike.foldl' f (Seq.empty, Loc 1 1 1)+-- | Adds locations to a list of characters.+locations :: Traversable t => t Char -> t (Char, Loc)+locations = snd . mapAccumL f (Loc 1 1 1)   where-    f (!sq, !loc) c = (sq |> (c, loc), advanceChar c loc)+    f loc char = (advanceChar char loc, (char, loc)) --- | Breaks a ListLike into a 'Seq' but does not assign locations.-noLocations-  :: ListLike.FoldableLL full item-  => full-  -> Seq (item, ())-noLocations = ListLike.foldl' f Seq.empty-  where-    f !sq c = sq |> (c, ())+-- | Takes a list of tokens and assigns empty locations.+noLocations :: Functor f => f a -> f (a, ())+noLocations = fmap (\a -> (a, ()))  -- | Obtains all full Earley parses from a given input string, after -- assigning a location to every 'Char'.  Example: -- 'Pinchot.Examples.Newman.address'. locatedFullParses-  :: ListLike.FoldableLL full Char-  => (forall r. Earley.Grammar r (Earley.Prod r String (Char, Loc) (p Char Loc)))+  :: (forall r. Earley.Grammar r (Earley.Prod r String (Char, Loc) (p Char Loc)))   -- ^ Earley grammar with production that you want to parse.-  -> full-  -- ^ Source text, e.g. 'String', 'Data.Text', etc.-  -> ([p Char Loc], Earley.Report String (Seq (Char, Loc)))+  -> [Char]+  -- ^ Source text+  -> ([p Char Loc], Earley.Report String [(Char, Loc)])   -- ^ A list of successful parses that when to the end of the   -- source string, along with the Earley report showing possible   -- errors.

@@ -0,0 +1,134 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Template Haskell names and values.+module Pinchot.Names where++import Control.Monad.Trans.Class (lift)+import qualified Control.Monad.Trans.State as St+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Language.Haskell.TH as T++-- | @t@+nameT :: T.Name+nameT = T.mkName "t"++-- | @a@+nameA :: T.Name+nameA = T.mkName "a"++-- | @r@+nameR :: T.Name+nameR = T.mkName "r"++-- | @t@ as a type+typeT :: T.TypeQ+typeT = T.varT nameT++-- | @a@ as a type+typeA :: T.TypeQ+typeA = T.varT nameA++-- | @r@ as a type+typeR :: T.TypeQ+typeR = T.varT nameR++-- | @t@ as a TyVarBndr+tyVarBndrT :: T.TyVarBndr+tyVarBndrT = T.PlainTV nameT++-- | @a@ as a TyVarBndr+tyVarBndrA :: T.TyVarBndr+tyVarBndrA = T.PlainTV nameA++-- | @r@ as a TyVarBndr+tyVarBndrR :: T.TyVarBndr+tyVarBndrR = T.PlainTV nameR++productionsStr :: String+productionsStr = "Productions"++-- | @Productions@+productions :: T.Name+productions = T.mkName productionsStr++-- | @a'@ followed by the given string.+recordName :: String -> T.Name+recordName n = T.mkName $ "a'" ++ n++-- | Qualified record name.+qualRecordName :: Qualifier -> String -> String+qualRecordName q s = quald q ("a'" ++ s)++-- | Environment for the creation of new names.  Each name is+-- associated with an arbitrary String.  Useful for assigning a new+-- unique name to match a particular Pinchot identifier.  Use+-- 'getName' to get the name associated with a particular identifier,+-- creating it if necessary.+newtype Namer a = Namer (St.StateT (Map String T.Name) T.Q a)+  deriving (Functor, Applicative, Monad)++liftQ :: T.Q a -> Namer a+liftQ = Namer . lift++namerNewName :: Namer T.Name+namerNewName = Namer $ lift (T.newName "_namerNewName")++runNamer :: Namer a -> T.Q a+runNamer (Namer n) = fmap fst $ (St.runStateT n) Map.empty++-- | Get th Name that corresponds to a particular string.  If+-- necessary, creates the name.+getName :: String -> Namer T.Name+getName str = Namer $ do+  names <- St.get+  case Map.lookup str names of+    Just n -> return n+    Nothing -> do+      new <- lift $ T.newName ("_getName_" ++ str)+      let newMap = Map.insert str new names+      St.put newMap+      return new++lookupValueName :: String -> T.Q T.Name+lookupValueName str = do+  mayName <- T.lookupValueName str+  case mayName of+    Nothing -> fail $ "name not found: " ++ str+    Just r -> return r++lookupTypeName :: String -> T.Q T.Name+lookupTypeName str = do+  mayName <- T.lookupTypeName str+  case mayName of+    Nothing -> fail $ "name not found: " ++ str+    Just r -> return r++-- | Many functions take an argument that holds the name qualifier+-- for the module that contains the data types created by applying a+-- function such as 'Pinchot.SyntaxTree.syntaxTrees' or+-- 'Pinchot.Earley.earleyProduct'.+--+-- You will have to make sure that these data types are in scope.+-- The spliced Template Haskell code has to know where to+-- look for these data types.  If you did an unqualified @import@ or+-- if the types are in the same module as the function that takes a+-- 'Qualifier' argument, just pass the empty string here.  If you did a+-- qualified import, use the appropriate qualifier here.+--+-- For example, if you used @import qualified MyAst@, pass+-- @\"MyAst\"@ here.  If you used @import qualified+-- Data.MyLibrary.MyAst as MyLibrary.MyAst@, pass+-- @\"MyLibrary.MyAst\"@ here.+type Qualifier = String+++-- | Prepends a qualifier to a string, and returns the resulting+-- Name.+quald+  :: Qualifier+  -> String+  -- ^ Item to be named - constructor, value, etc.+  -> String+quald qual suf+  | null qual = suf+  | otherwise = (qual ++ '.':suf)

@@ -2,27 +2,18 @@  module Pinchot.Pretty where -import Data.Foldable (toList)-import Data.Sequence (Seq)-import Data.Sequence.NonEmpty (NonEmptySeq(NonEmptySeq))+import Data.List.NonEmpty (NonEmpty((:|))) import Text.Show.Pretty (Value) import qualified Text.Show.Pretty as Pretty import qualified Text.Earley as Earley --- | Prettify a 'Seq'.-prettySeq :: (a -> Value) -> Seq a -> Value-prettySeq f-  = Pretty.Con "Seq"-  . (:[])-  . Pretty.List-  . fmap f-  . toList+prettyList :: (a -> Value) -> [a] -> Value+prettyList f = Pretty.List . fmap f --- | Prettify a 'NonEmptySeq'.-prettyNonEmptySeq :: (a -> Value) -> NonEmptySeq a -> Value-prettyNonEmptySeq f (NonEmptySeq a1 as)-  = Pretty.Rec "NonEmptySeq"-               [("_fore", f a1), ("_aft", prettySeq f as)]+-- | Prettify a 'NonEmpty'.+prettyNonEmpty :: (a -> Value) -> NonEmpty a -> Value+prettyNonEmpty f (a1 :| as)+  = Pretty.Con ":|" [(f a1), (Pretty.List (fmap f as))]  -- | Prettify a 'Maybe'. prettyMaybe@@ -47,10 +38,10 @@ -- | Prettify the output of 'Pinchot.Locator.locatedFullParses'. prettyFullParses   :: (Pretty.PrettyVal p, Pretty.PrettyVal v)-  => ([p], Earley.Report String (Seq v))+  => ([p], Earley.Report String [v])   -> Value prettyFullParses x = Pretty.Tuple   [ Pretty.prettyVal . fst $ x-  , prettyReport Pretty.prettyVal (prettySeq Pretty.prettyVal)+  , prettyReport Pretty.prettyVal (prettyList Pretty.prettyVal)       . snd $ x   ]

@@ -57,20 +57,18 @@   -> T.ExpQ   -- ^ Returns an expression whose value is the final return value   -- from the @do@ block.-recursiveDo binds final = [| fmap fst $ mfix $(fn) |]-  where-    fn = [| \ $(lazyPattern (fmap fst binds)) -> $doBlock |]-    doBlock = T.doE (bindStmts ++ returnStmts)-    bindStmts = map mkBind binds-      where-        mkBind (name, exp)-          = T.bindS (T.varP name) exp-    returnStmts = [bindRtnVal, returner]-      where-        rtnValName = T.mkName "_returner"-        bindRtnVal = T.bindS (T.varP rtnValName) final-        returner-          = T.noBindS-            [| return $(bigTuple (T.varE rtnValName) -                                 (fmap (T.varE . fst) binds)) |]-+recursiveDo binds final = do+  rtnValName <- T.newName "_returner"+  let bindStmts = map mkBind binds+        where+          mkBind (name, exp) = T.bindS (T.varP name) exp+      fn = [| \ $(lazyPattern (fmap fst binds)) -> $doBlock |]+      returnStmts = [bindRtnVal, returner]+        where+          bindRtnVal = T.bindS (T.varP rtnValName) final+          returner+            = T.noBindS+              [| return $(bigTuple (T.varE rtnValName) +                                  (fmap (T.varE . fst) binds)) |]+      doBlock = T.doE (bindStmts ++ returnStmts)+  [| fmap fst $ mfix $(fn) |]

@@ -1,18 +1,15 @@ {-# OPTIONS_HADDOCK not-home #-}-{-# LANGUAGE OverloadedLists #-} module Pinchot.Rules where  import Control.Monad (join) import Control.Monad.Trans.State (get, put, State) import qualified Control.Monad.Trans.State as State-import Data.Sequence (Seq, (<|))-import qualified Data.Sequence as Seq-import qualified Data.Sequence.NonEmpty as NE+import qualified Data.List.NonEmpty as NE import Data.Set (Set) import qualified Data.Set as Set+import qualified Language.Haskell.TH as T  import Pinchot.Types-import Pinchot.Intervals  -- | Name a 'Rule' for use in error messages.  If you do not name a -- rule using this combinator, the rule's type name will be used in@@ -34,10 +31,18 @@ -- 'Pinchot.Examples.Postal.rLetter'. terminal   :: RuleName-  -> Intervals t-  -- ^ Valid terminal symbols+  -> T.Q (T.TExp (t -> Bool))+  -- ^ Valid terminal symbols.  This is a typed Template Haskell+  -- expression.  To use it, make sure you have+  --+  -- > {-# LANGUAGE TemplateHaskell #-}+  --+  -- at the top of your module, and then use the Template Haskell+  -- quotes, like this:+  --+  -- > terminal "AtoZ" [|| (\c -> c >= 'A' && c <= 'Z') ||]   -> Rule t-terminal n i = rule n (Terminal i)+terminal n i = rule n (Terminal (Predicate i))  -- | Creates a non-terminal production rule.  This is the most -- flexible way to create non-terminals.  You can even create a@@ -47,12 +52,12 @@ nonTerminal   :: RuleName   -- ^ Will be used for the name of the resulting type-  -> Seq (BranchName, Seq (Rule t))-  -- ^ Branches of the non-terminal production rule.  This 'Seq'+  -> [(BranchName, [Rule t])]+  -- ^ Branches of the non-terminal production rule.  This list   -- must have at least one element; otherwise, an error will   -- result.   -> Rule t-nonTerminal n branches = case NE.seqToNonEmptySeq branches of+nonTerminal n branches = case NE.nonEmpty branches of   Nothing -> error $ "nonTerminal: rule has no branches: " ++ n   Just bs -> rule n . NonTerminal . fmap (uncurry Branch) $ bs @@ -69,18 +74,18 @@ union   :: RuleName   -- ^ Will be used for the name of the resulting type-  -> Seq (Rule t)+  -> [Rule t]   -- ^ List of branches.  There must be at least one branch;   -- otherwise a compile-time error will occur.   -> Rule t union n rs = nonTerminal n (fmap f rs)   where     f rule@(Rule branchName _ _)-      = (n ++ '\'' : branchName, Seq.singleton rule)+      = (n ++ '\'' : branchName, [rule])  -- | Creates a production for a sequence of terminals.  Useful for -- parsing specific words.  When used with 'Pinchot.syntaxTrees', the--- resulting data type is a @newtype@ that wraps a @'NE.NonEmptySeq'+-- resulting data type is a @newtype@ that wraps a @'NE.NonEmpty' -- (t, a)@, where @t@ is the type of the token (often 'Char') and @a@ -- is an arbitrary metadata type. --@@ -95,7 +100,7 @@   -- otherwise this function will apply 'error'.  This list must be   -- finite.   -> Rule t-series n = rule n . Series . get . NE.seqToNonEmptySeq . Seq.fromList+series n = rule n . Series . get . NE.nonEmpty   where     get Nothing = error $ "term function used with empty list for rule: " ++ n     get (Just a) = a@@ -130,7 +135,7 @@   -- ^ The name of this rule, which is used both as the type name   -- and for the name of the sole data constructor -  -> Seq (Rule t)+  -> [Rule t]   -- ^ The right-hand side of this rule.  This sequence can be empty,   -- which results in an epsilon production.   -> Rule t@@ -170,34 +175,34 @@  -- | Gets all ancestor rules to this 'Rule'.  Includes the current -- rule if it has not already been seen.-getAncestors :: Rule t -> State (Set RuleName) (Seq (Rule t))+getAncestors :: Rule t -> State (Set RuleName) [Rule t] getAncestors r@(Rule name _ ty) = do   set <- get   if Set.member name set-    then return Seq.empty+    then return []     else do       put (Set.insert name set)       case ty of-        Terminal _ -> return (Seq.singleton r)+        Terminal _ -> return [r]         NonTerminal bs -> do-          ass <- fmap join . traverse branchAncestors . NE.nonEmptySeqToSeq $ bs-          return $ r <| ass+          ass <- fmap join . traverse branchAncestors . NE.toList $ bs+          return $ r : ass         Wrap c -> do           cs <- getAncestors c-          return $ r <| cs+          return $ r : cs         Record ls -> do           cs <- fmap join . traverse getAncestors $ ls-          return $ r <| cs+          return $ r : cs         Opt c -> do           cs <- getAncestors c-          return $ r <| cs+          return $ r : cs         Star c -> do           cs <- getAncestors c-          return $ r <| cs+          return $ r : cs         Plus c -> do           cs <- getAncestors c-          return $ r <| cs-        Series _ -> return (Seq.singleton r)+          return $ r : cs+        Series _ -> return [r]   where     branchAncestors (Branch _ rs) = fmap join . traverse getAncestors $ rs @@ -205,14 +210,14 @@ -- duplicates. family   :: Rule t-  -> Seq (Rule t)+  -> [Rule t] family rule = State.evalState (getAncestors rule) Set.empty  -- | Gets all the ancestor 'Rule's of a sequence of 'Rule'.  Includes -- each 'Rule' that is in the sequence.  Skips duplicates. families-  :: Seq (Rule t)-  -> Seq (Rule t)+  :: [Rule t]+  -> [Rule t] families   = join   . flip State.evalState Set.empty

@@ -1,14 +1,13 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE TemplateHaskell #-}--- | Grower - grows the types to hold a syntax tree+-- | Grows the types to hold a syntax tree.  module Pinchot.SyntaxTree where -import Data.Foldable (toList)-import Data.Sequence (Seq)-import Data.Sequence.NonEmpty (NonEmptySeq)+import Data.List.NonEmpty (NonEmpty, toList) import qualified Language.Haskell.TH as T +import Pinchot.Names import Pinchot.Rules import Pinchot.Types @@ -20,11 +19,10 @@ syntaxTrees   :: [T.Name]   -- ^ What to derive, e.g. @[''Eq, ''Ord, ''Show]@-  -> Seq (Rule t)+  -> [Rule t]   -> T.DecsQ syntaxTrees derives   = traverse (ruleToType derives)-  . toList   . families  branchConstructor :: Branch t -> T.ConQ@@ -32,13 +30,11 @@   where     name = T.mkName nm     mkField (Rule n _ _) = notStrict-      [t| $(T.conT (T.mkName n)) $(charTypeVar) $(anyTypeVar) |]+      [t| $(T.conT (T.mkName n)) $(typeT) $(typeA) |]       where         notStrict = T.bangType           (T.bang T.noSourceUnpackedness T.noSourceStrictness)-    fields = toList . fmap mkField $ rules-    anyTypeVar = T.varT (T.mkName "a")-    charTypeVar = T.varT (T.mkName "t")+    fields = fmap mkField $ rules  -- | Makes the top-level declaration for a given rule. ruleToType@@ -48,71 +44,66 @@   -> T.Q T.Dec ruleToType deriveNames (Rule nm _ ruleType) = case ruleType of   Terminal _ ->-    T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives+    T.newtypeD (T.cxt []) name [tyVarBndrT, tyVarBndrA] Nothing newtypeCon derives     where       newtypeCon = T.normalC name         [notStrict-          [t| ( $(charTypeVar), $(anyTypeVar) ) |] ]+          [t| ( $(typeT), $(typeA) ) |] ] -  NonTerminal bs -> T.dataD (T.cxt []) name [charType, anyType] Nothing cons derives+  NonTerminal bs -> T.dataD (T.cxt []) name [tyVarBndrT, tyVarBndrA] Nothing cons derives     where       cons = toList (fmap branchConstructor bs)    Wrap (Rule inner _ _) ->-    T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives+    T.newtypeD (T.cxt []) name [tyVarBndrT, tyVarBndrA] Nothing newtypeCon derives     where       newtypeCon = T.normalC name         [ notStrict-            [t| $(T.conT (T.mkName inner)) $(charTypeVar) $(anyTypeVar) |] ]+            [t| $(T.conT (T.mkName inner)) $(typeT) $(typeA) |] ] -  Record sq -> T.dataD (T.cxt []) name [charType, anyType] Nothing [ctor] derives+  Record sq -> T.dataD (T.cxt []) name [tyVarBndrT, tyVarBndrA] Nothing [ctor] derives     where-      ctor = T.recC name . zipWith mkField [(0 :: Int) ..] . toList $ sq+      ctor = T.recC name . zipWith mkField [(0 :: Int) ..] $ sq       mkField num (Rule rn _ _) = T.varBangType (T.mkName fldNm)         (notStrict-          [t| $(T.conT (T.mkName rn)) $(charTypeVar) $(anyTypeVar) |])+          [t| $(T.conT (T.mkName rn)) $(typeT) $(typeA) |])         where           fldNm = '_' : recordFieldName num nm rn    Opt (Rule inner _ _) ->-    T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives+    T.newtypeD (T.cxt []) name [tyVarBndrT, tyVarBndrA] Nothing newtypeCon derives     where       newtypeCon = T.normalC name         [notStrict-          [t| Maybe ( $(T.conT (T.mkName inner)) $(charTypeVar)-                                                 $(anyTypeVar)) |]]+          [t| Maybe ( $(T.conT (T.mkName inner)) $(typeT)+                                                 $(typeA)) |]]    Star (Rule inner _ _) ->-    T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives+    T.newtypeD (T.cxt []) name [tyVarBndrT, tyVarBndrA] Nothing newtypeCon derives     where       newtypeCon = T.normalC name [sq]         where           sq = notStrict-            [t| Seq ( $(T.conT (T.mkName inner)) $(charTypeVar)-                                                 $(anyTypeVar) ) |]+            [t| [$(T.conT (T.mkName inner)) $(typeT) $(typeA)]  |]    Plus (Rule inner _ _) ->-    T.newtypeD (T.cxt []) name [charType, anyType] Nothing cons derives+    T.newtypeD (T.cxt []) name [tyVarBndrT, tyVarBndrA] Nothing cons derives     where       cons = T.normalC name [ne]         where-          ne = notStrict [t| NonEmptySeq $(ins) |]+          ne = notStrict [t| NonEmpty $(ins) |]             where               ins = [t| $(T.conT (T.mkName inner))-                $(charTypeVar) $(anyTypeVar) |]+                $(typeT) $(typeA) |]    Series _ ->-    T.newtypeD (T.cxt []) name [charType, anyType] Nothing cons derives+    T.newtypeD (T.cxt []) name [tyVarBndrT, tyVarBndrA] Nothing cons derives     where       cons = T.normalC name [sq]-      sq = notStrict [t| NonEmptySeq ( $(charTypeVar), $(anyTypeVar) ) |]+      sq = notStrict [t| NonEmpty ( $(typeT), $(typeA) ) |]    where     name = T.mkName nm-    anyType = T.PlainTV (T.mkName "a")-    anyTypeVar = T.varT (T.mkName "a")-    charType = T.PlainTV (T.mkName "t")-    charTypeVar = T.varT (T.mkName "t")     derives = mapM T.conT deriveNames     notStrict = T.bangType       (T.bang T.noSourceUnpackedness T.noSourceStrictness)

@@ -12,12 +12,11 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Semigroup ((<>))-import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import Data.Sequence.NonEmpty (NonEmptySeq)+import Data.List.NonEmpty (NonEmpty) import qualified Language.Haskell.TH as T import qualified Text.Show.Pretty as Pretty +import Pinchot.Names import Pinchot.Types import Pinchot.Pretty import Pinchot.Rules@@ -35,9 +34,9 @@ -- Example: "Pinchot.Examples.SyntaxTrees".  bifunctorInstances-  :: Seq (Rule t)+  :: [Rule t]   -> T.DecsQ-bifunctorInstances = traverse f . toList . families+bifunctorInstances = traverse f . families   where     f rule@(Rule ruleName _ _) = T.instanceD (T.cxt [])       [t| Bifunctor.Bifunctor $(T.conT (T.mkName ruleName)) |]@@ -60,18 +59,16 @@ -- Example: "Pinchot.Examples.SyntaxTrees".  semigroupInstances-  :: Seq (Rule t)+  :: [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.conT (T.mkName ruleName)) $(typeT) $(typeA)) |]           [T.valD (T.varP '(Semigroup.<>))                   (T.normalB expn) []] @@ -90,17 +87,15 @@ -- -- Example: "Pinchot.Examples.SyntaxTrees". monoidInstances-  :: Seq (Rule t)+  :: [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| Monoid ( $( T.conT (T.mkName ruleName) ) $(typeT) $(typeA) ) |]           [ T.valD (T.varP 'mappend)                    (T.normalB expAppend) []           , T.valD (T.varP 'mempty)@@ -171,8 +166,9 @@   -> 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))+  ctorName <- lookupValueName (quald qual name)+  let body = T.lamE [T.conP ctorName [T.varP val]]+        [| $(T.conE ctorName)               ( $(T.varE fa) . fst $ $(T.varE val)               , $(T.varE fb) . snd $ $(T.varE val)               )@@ -199,8 +195,9 @@   -> 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))+  ctorName <- lookupValueName (quald qual name)+  let expn = T.lamE [T.conP ctorName [T.varP val]]+        [| $(T.conE ctorName)             ( $(T.varE (errLookup inner lkp)) $(T.varE val) ) |]   return $ T.valD (T.varP (errLookup name lkp)) (T.normalB expn) [] @@ -208,7 +205,7 @@   :: Qualifier   -> Map RuleName T.Name   -> RuleName-  -> Seq (Rule t)+  -> [Rule t]   -> T.Q T.DecQ recordBimapLetBind qual lkp name sq = do   let clause = recordBimapClause qual lkp name sq@@ -218,15 +215,16 @@   :: Qualifier   -> Map RuleName T.Name   -> RuleName-  -> Seq (Rule t)+  -> [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+  ctorName <- lookupValueName (quald qual name)+  let body = foldl f (T.conE ctorName) . 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) []+  T.clause [T.conP ctorName pats] (T.normalB body) []  recordBimapLetBindField   :: Map RuleName T.Name@@ -247,11 +245,12 @@   -> 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+  ctorName <- lookupValueName (quald qual name)+  let body = [| $(T.conE ctorName) $ 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]]+  let clause = T.clause [T.conP ctorName [T.varP val]]         (T.normalB body) []   return $ T.funD (errLookup name lkp) [clause] @@ -265,9 +264,10 @@   -> T.Q T.DecQ starBimapLetBind qual lkp name inner = do   val <- T.newName $ "starBimapLetBind" ++ name-  let body = [| $(T.conE (quald qual name))+  ctorName <- lookupValueName (quald qual name)+  let body = [| $(T.conE ctorName)                 $ fmap $(T.varE (errLookup inner lkp)) $(T.varE val) |]-  let clause = T.clause [T.conP (quald qual name) [T.varP val]]+  let clause = T.clause [T.conP ctorName [T.varP val]]         (T.normalB body) []   return $ T.funD (errLookup name lkp) [clause] @@ -281,9 +281,10 @@   -> T.Q T.DecQ plusBimapLetBind qual lkp name inner = do   val <- T.newName $ "plusBimapLetBind" ++ name-  let body = [| $(T.conE (quald qual name))+  ctorName <- lookupValueName (quald qual name)+  let body = [| $(T.conE ctorName)                 $ fmap $(T.varE (errLookup inner lkp)) $(T.varE val) |]-  let clause = T.clause [T.conP (quald qual name) [T.varP val]]+  let clause = T.clause [T.conP ctorName [T.varP val]]         (T.normalB body) []   return $ T.funD (errLookup name lkp) [clause] @@ -296,8 +297,9 @@   -> T.Q T.DecQ seriesBimapLetBind qual fa fb lkp name = do   val <- T.newName $ "termBimapLetBind" ++ name-  let body = T.lamE [T.conP (quald qual name) [T.varP val]]-        [| $(T.conE (quald qual name))+  ctorName <- lookupValueName (quald qual name)+  let body = T.lamE [T.conP ctorName [T.varP val]]+        [| $(T.conE ctorName)               (fmap ( Bifunctor.bimap $(T.varE fa) $(T.varE fb) )                     $(T.varE val) ) |]   return $ T.valD (T.varP (errLookup name lkp)) (T.normalB body) []@@ -338,11 +340,13 @@  wrappedMemptyExpression   :: Qualifier-  -> Seq RuleName+  -> [RuleName]   -> T.ExpQ wrappedMemptyExpression qual rules = foldr f [| mempty |] rules   where-    f name acc = [| $(T.conE (quald qual name)) $(acc) |]+    f name acc = do+      ctorName <- lookupValueName (quald qual name)+      [| $(T.conE ctorName) $(acc) |]  -- | If possible, creates an expression of type --@@ -359,12 +363,12 @@  monoidCtors   :: Rule t-  -> Maybe (Seq RuleName)+  -> Maybe ([RuleName]) monoidCtors (Rule ruleName _ ty) = case ty of   Wrap r -> do     rest <- monoidCtors r     return $ ruleName `Lens.cons` rest-  Star _ -> Just (Seq.singleton ruleName)+  Star _ -> Just [ruleName]   _ -> Nothing  -- | If possible, creates an expression of type@@ -384,20 +388,20 @@  semigroupCtors   :: Rule t-  -> Maybe (Seq RuleName)+  -> Maybe ([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)+  Plus _ -> Just [ruleName]+  Star _ -> Just [ruleName]   _ -> Nothing  wrappedSemigroupExpression   :: T.Name   -- ^ mappend operator   -> Qualifier-  -> Seq RuleName+  -> [RuleName]   -- ^ Rule names, with the outermost name on the left side of the   -- 'Seq'.   -> T.ExpQ@@ -414,11 +418,15 @@       where         mkPat name = foldr f (T.varP name) rules           where-            f rule acc = T.conP (quald qual rule) [acc]+            f rule acc = do+              ctorName <- lookupValueName (quald qual rule)+              T.conP ctorName [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+            f rule acc = do+              ctorName <- lookupValueName (quald qual rule)+              T.appE (T.conE ctorName) acc  -- | Creates an expression of type --@@ -444,13 +452,11 @@   :: Rule t   -> T.DecQ prettyInstance rule = do-  let a = T.varT $ T.mkName "a"-      t = T.varT $ T.mkName "t"-      ruleTypeName = T.conT . T.mkName . _ruleName $ rule-      cxt = [ [t| Pretty.PrettyVal $t |]-            , [t| Pretty.PrettyVal $a |]+  let ruleTypeName = T.conT . T.mkName . _ruleName $ rule+      cxt = [ [t| Pretty.PrettyVal $typeT |]+            , [t| Pretty.PrettyVal $typeA |]             ]-      ty = [t| Pretty.PrettyVal ( $ruleTypeName $t $a ) |]+      ty = [t| Pretty.PrettyVal ( $ruleTypeName $typeT $typeA ) |]       dec = T.funD 'Pretty.prettyVal [clause]         where           clause = T.clause [] (T.normalB (prettyExpression "" rule)) []@@ -477,7 +483,7 @@ -- -- Example: "Pinchot.Examples.SyntaxTrees". prettyInstances-  :: Seq (Rule t)+  :: [Rule t]   -> T.DecsQ prettyInstances   = fmap toList . sequence . fmap prettyInstance . families@@ -494,13 +500,15 @@ prettyExpressionInEnv qual lkp (Rule name _ ty) = case ty of   Terminal _ -> do     x <- T.newName "x"-    [| \ $(T.conP (quald qual name) [T.varP x])+    ctorName <- lookupValueName (quald qual name)+    [| \ $(T.conP ctorName [T.varP x])           -> Pretty.Con name [Pretty.prettyVal $(T.varE x)] |]   NonTerminal sq -> prettyBranches qual lkp sq   Wrap (Rule inner _ _) -> do     x <- T.newName "x"+    ctorName <- lookupValueName (quald qual name)     fVal <- lookupRule lkp inner-    [| \ $(T.conP (quald qual name) [T.varP x])+    [| \ $(T.conP ctorName [T.varP x])          -> Pretty.Con name [$(T.varE fVal) $(T.varE x)] |]   Record rules -> do     (pat, expn) <- prettyConstructor qual lkp name rules@@ -508,28 +516,32 @@   Opt (Rule inner _ _) -> do     x <- T.newName "x"     fVal <- lookupRule lkp inner-    [| \ $(T.conP (quald qual name) [T.varP x]) ->+    ctorName <- lookupValueName (quald qual name)+    [| \ $(T.conP ctorName [T.varP x]) ->       Pretty.Con name [prettyMaybe $(T.varE fVal) $(T.varE x)] |]   Star (Rule inner _ _) -> do     x <- T.newName "x"     fVal <- lookupRule lkp inner-    [| \ $(T.conP (quald qual name) [T.varP x]) ->-       Pretty.Con name [prettySeq $(T.varE fVal) $(T.varE x)] |]+    ctorName <- lookupValueName (quald qual name)+    [| \ $(T.conP ctorName [T.varP x]) ->+       Pretty.Con name [prettyList $(T.varE fVal) $(T.varE x)] |]   Plus (Rule inner _ _) -> do     x <- T.newName "x"     fVal <- lookupRule lkp inner-    [| \ $(T.conP (quald qual name) [T.varP x]) ->-       Pretty.Con name [prettyNonEmptySeq $(T.varE fVal) $(T.varE x)] |]+    ctorName <- lookupValueName (quald qual name)+    [| \ $(T.conP ctorName [T.varP x]) ->+       Pretty.Con name [prettyNonEmpty $(T.varE fVal) $(T.varE x)] |]   Series _ -> do     x <- T.newName "x"-    [| \ $(T.conP (quald qual name) [T.varP x])+    ctorName <- lookupValueName (quald qual name)+    [| \ $(T.conP ctorName [T.varP x])          -> Pretty.Con name-            [prettyNonEmptySeq Pretty.prettyVal $(T.varE x)] |]+            [prettyNonEmpty Pretty.prettyVal $(T.varE x)] |]  prettyBranches   :: Qualifier   -> Map RuleName T.Name-  -> NonEmptySeq (Branch t)+  -> NonEmpty (Branch t)   -> T.ExpQ prettyBranches qual lkp branches = do   x <- T.newName "x"@@ -576,11 +588,11 @@   -> Map RuleName T.Name   -> String   -- ^ Name of branch, or name of data constructor-  -> Seq (Rule t)+  -> [Rule t]   -> T.Q (T.PatQ, T.ExpQ)-prettyConstructor qual lkp branchName branches-  = deconstruct (quald qual branchName) (length fieldNames)-      getFinal+prettyConstructor qual lkp branchName branches = do+  ctorName <- lookupValueName (quald qual branchName)+  deconstruct ctorName (length fieldNames) getFinal   where     fieldNames = toList . fmap _ruleName $ branches     getFinal fields = [| Pretty.Con branchName $(values) |]

@@ -1,16 +1,15 @@ {-# LANGUAGE TemplateHaskell #-} module Pinchot.SyntaxTree.Optics where -import Data.Foldable (toList)-import Data.Sequence (Seq)-import Data.Sequence.NonEmpty (NonEmptySeq)+import Data.Data (Data)+import Data.List.NonEmpty (NonEmpty, toList) import qualified Control.Lens as Lens import qualified Language.Haskell.TH as T import qualified Language.Haskell.TH.Syntax as Syntax +import Pinchot.Names import Pinchot.Rules import Pinchot.Types-import Pinchot.Intervals  -- | Creates optics declarations for a 'Rule', if optics can -- be made for the 'Rule':@@ -21,21 +20,22 @@ -- -- * 'Pinchot.record' gets a single 'Lens.Lens' ----- * 'Pinchot.wrap', 'Pinchot.opt', 'Pinchot.star',--- and 'Pinchot.plus' do not get optics.+-- * 'Pinchot.wrap', 'Pinchot.opt', 'Pinchot.star', and 'Pinchot.plus'+-- do not get optics.  For those, you will typically want to use+-- 'Pinchot.wrappedInstances'. -- -- Each rule in the sequence of 'Rule', as well as all ancestors of -- those 'Rule's, will be handled. -- -- Example: "Pinchot.Examples.RulesToOptics". rulesToOptics-  :: Syntax.Lift t+  :: (Syntax.Lift t, Data t)   => Qualifier   -- ^ Qualifier for module containing the data types that will get   -- optics   -> T.Name   -- ^ Type name for the terminal-  -> Seq (Rule t)+  -> [Rule t]   -> T.Q [T.Dec] rulesToOptics qual termName   = fmap concat@@ -49,13 +49,13 @@ -- -- * 'NonTerminal' gets a 'Lens.Prism' for each constructor ----- * 'Terminals' gets a single 'Lens.Prism'+-- * 'Series' gets a single 'Lens.Prism' -- -- * 'Record' gets a single 'Lens.Lens' -- -- * 'Wrap', 'Opt', 'Star', and 'Plus' do not get optics. ruleToOptics-  :: Syntax.Lift t+  :: (Syntax.Lift t, Data t)   => Qualifier   -- ^ Qualifier for module containing the data type that will get   -- optics@@ -64,9 +64,10 @@   -> Rule t   -> T.Q [T.Dec] ruleToOptics qual termName (Rule nm _ ty) = case ty of-  Terminal ivls -> terminalToOptics qual termName nm ivls+  Terminal pdct -> terminalToOptics qual termName nm pdct   NonTerminal bs -> sequence $ nonTerminalToOptics qual nm bs   Record sq -> sequence $ recordsToOptics qual nm sq+  Series ne -> seriesToOptics qual termName nm ne   _ -> return []    @@ -84,30 +85,175 @@   -- ^ Terminal type name   -> String   -- ^ Rule name-  -> Intervals t+  -> Predicate t   -> T.Q [T.Dec]-terminalToOptics qual termName nm ivls = do+terminalToOptics qual termName nm (Predicate pdct) = do+  ctorName <- lookupTypeName (quald qual nm)   e1 <- T.sigD (T.mkName ('_':nm))-    $ T.forallT [ T.PlainTV (T.mkName "a")] (return [])-    [t| Lens.Prism' ( $(T.conT termName), $(anyType) )-                    ($(T.conT (quald qual nm)) $(T.conT termName) $(anyType))+    $ T.forallT [ tyVarBndrA] (return [])+    [t| Lens.Prism' ( $(T.conT termName), $(typeA) )+                    ( $(T.conT ctorName) $(T.conT termName) $(typeA))     |]      e2 <- T.valD prismName (T.normalB expn) []   return [e1, e2]   where-    anyType = T.varT (T.mkName "a")     prismName = T.varP (T.mkName ('_' : nm))-    fetchPat = T.conP (quald qual nm) [T.varP (T.mkName "_x")]-    fetchName = T.varE (T.mkName "_x")-    ctor = T.conE (quald qual nm)-    expn = [| let fetch $fetchPat = $fetchName-                  store (term, a)-                    | inIntervals ivls term = Just ($(ctor) (term, a))-                    | otherwise = Nothing-              in Lens.prism' fetch store-           |]+    expn = do+      x <- T.newName "_x"+      ctorName <- lookupValueName (quald qual nm)+      let fetchPat = T.conP ctorName [T.varP x]+          fetchName = T.varE x+      [| let fetch $fetchPat = $fetchName+             store (term, a)+                 | $(fmap T.unType pdct) term+                    = Just ($(T.conE ctorName) (term, a))+                 | otherwise = Nothing+               in Lens.prism' fetch store+        |] ++seriesToOptics+  :: (Data t, Syntax.Lift t)+  => Qualifier+  -- ^ Qualifier for module containing the data type that will get+  -- optics+  -> T.Name+  -- ^ Terminal type name+  -> String+  -- ^ Rule name+  -> NonEmpty t+  -> T.Q [T.Dec]+seriesToOptics qual termName nm terminals = do+  ctorName <- lookupTypeName (quald qual nm)+  e1 <- T.sigD (T.mkName ('_':nm))+    $ T.forallT [ tyVarBndrA] (return [])+    [t| Lens.Prism' (NonEmpty ( $(T.conT termName), $(typeA) ))+                    ( $(T.conT ctorName) $(T.conT termName) $(typeA))+    |]+  +  e2 <- T.valD prismName (T.normalB expn) []+  return [e1, e2]+  where+    prismName = T.varP (T.mkName ('_' : nm))+    expn = do+      x <- T.newName "_x"+      ctorName <- lookupValueName (quald qual nm)+      let fetchPat = T.conP ctorName [T.varP x]+          fetchName = T.varE x+      [| let fetch $fetchPat = $fetchName+             store terms+                 | fmap fst terms == $(Syntax.liftData terminals)+                    = Just ($(T.conE ctorName) terms )+                 | otherwise = Nothing+               in Lens.prism' fetch store+        |]+++prismSignature+  :: Qualifier+  -> String+  -- ^ Rule name+  -> Branch t+  -> T.DecQ+prismSignature qual nm (Branch inner rules) = do+  ctorName <- lookupTypeName (quald qual nm)+  T.sigD prismName+    (forallA [t| Lens.Prism'+        ($(T.conT ctorName) $(typeT) $(typeA))+        $(fieldsType) |])+  where+    prismName = T.mkName ('_' : inner)+    fieldsType = case rules of+      [] -> T.tupleT 0+      Rule r1 _ _ : [] -> do+        ctorName <- lookupTypeName (quald qual r1)+        [t| $(T.conT ctorName) $(typeT) $(typeA) |]+      rs -> foldl addType (T.tupleT (length rs)) rs+        where+          addType soFar (Rule r _ _) = do+            ctorName <- lookupTypeName (quald qual r)+            soFar `T.appT`+              [t| $(T.conT ctorName) $(typeT) $(typeA) |]++setterPatAndExpn+  :: Qualifier+  -> BranchName+  -> [a]+  -- ^ List of rules+  -> T.Q (T.PatQ, T.ExpQ)+setterPatAndExpn qual inner rules = do+  names <- sequence . flip replicate (T.newName "_setterPatAndExpn")+    . length $ rules+  let pat = T.tupP . fmap T.varP $ names+      expn = foldl addVar start names+        where+          start = do+            ctorName <- lookupValueName (quald qual inner)+            T.conE ctorName+          addVar acc nm = acc `T.appE` (T.varE nm)+  return (pat, expn)++prismSetter+  :: Qualifier+  -> Branch t+  -> T.ExpQ+prismSetter qual (Branch inner rules) = do+  (pat, expn) <- setterPatAndExpn qual inner rules+  T.lamE [pat] expn++-- | Returns a pattern and expression to match a particular branch; if+-- there is a match, the expression will return each field, in a tuple+-- in a Right.+rightPatternAndExpression+  :: Qualifier+  -> BranchName+  -> Int+  -- ^ Number of fields+  -> T.Q (T.PatQ, T.ExpQ)+rightPatternAndExpression qual inner n = do+  names <- sequence . replicate n $ T.newName "_patternAndExpression"+  ctorName <- lookupValueName (quald qual inner)+  let pat = T.conP ctorName . fmap T.varP $ names+      expn = T.appE (T.conE 'Right)+        . T.tupE+        . fmap T.varE+        $ names+  return (pat, expn)++-- | Returns a pattern and expression for branches that did not match.+-- Does not return anything if there are no other branches.+leftPatternAndExpression+  :: [a]+  -- ^ List of all other branches+  -> Maybe (T.Q (T.PatQ, T.ExpQ))+leftPatternAndExpression ls+  | null ls = Nothing+  | otherwise = Just $ do+      local <- T.newName "_leftPatternAndExpression"+      return (T.varP local, T.appE (T.conE 'Left) (T.varE local))+  ++prismGetter+  :: Qualifier+  -> Branch t+  -- ^ Make prism for this branch+  -> [Branch t] +  -- ^ List of all branches+  -> T.ExpQ+prismGetter qual (Branch inner rules) bs = do+  local <- T.newName "_prismGetter"+  (patCtor, bodyCtor) <- rightPatternAndExpression qual inner (length rules)+  let firstElem = T.match patCtor (T.normalB bodyCtor) []+  lastElem <- case leftPatternAndExpression bs of+    Nothing -> return []+    Just computation -> do+      (patLeft, expLeft) <- computation+      return [T.match patLeft (T.normalB expLeft) []]+  T.lamE [T.varP local]+    (T.caseE (T.varE local) $ firstElem : lastElem)++ -- | Creates prisms for each 'Branch'. nonTerminalToOptics   :: Qualifier@@ -115,128 +261,101 @@   -- optics   -> String   -- ^ Rule name-  -> NonEmptySeq (Branch t)+  -> NonEmpty (Branch t)   -> [T.Q T.Dec] nonTerminalToOptics qual nm bsSeq = concat $ fmap makePrism bs   where     bs = toList bsSeq-    makePrism (Branch inner rulesSeq) = [ signature, binding ]+    makePrism branch@(Branch inner _) =+      [ prismSignature qual nm branch, binding ]       where-        charType = T.varT (T.mkName "t")-        anyType = T.varT (T.mkName "a")-        rules = toList rulesSeq         prismName = T.mkName ('_' : inner)-        signature = T.sigD prismName-          (forallA [t| Lens.Prism'-              ($(T.conT (quald qual nm)) $(charType) $(anyType))-              $(fieldsType) |])-          where-            fieldsType = case rules of-              [] -> T.tupleT 0-              Rule r1 _ _ : [] -> [t| $(T.conT (quald qual r1))-                $(charType) $(anyType) |]-              rs -> foldl addType (T.tupleT (length rs)) rs-                where-                  addType soFar (Rule r _ _) = soFar `T.appT`-                    [t| $(T.conT (quald qual r)) $(charType) $(anyType) |]         binding = T.valD (T.varP prismName) body []           where             body = T.normalB               $ (T.varE 'Lens.prism)-              `T.appE` setter-              `T.appE` getter-              where-                setter = T.lamE [pat] expn-                  where-                    (pat, expn) = case rules of-                      [] -> (T.tupP [], T.conE (quald qual inner))-                      _ : [] -> (T.varP local,-                        T.conE (quald qual inner)-                        `T.appE` T.varE local)-                        where-                          local = T.mkName "_x"-                      ls -> (T.tupP pats, set)-                        where-                          pats = fmap (\i -> T.varP (T.mkName ("_x" ++ show i)))-                            . take (length ls) $ [(0 :: Int) ..]-                          set = foldl addVar start . take (length ls)-                            $ [(0 :: Int) ..]-                            where-                              addVar acc i = acc `T.appE`-                                (T.varE (T.mkName ("_x" ++ show i)))-                              start = T.conE (quald qual inner)+              `T.appE` (prismSetter qual branch)+              `T.appE` (prismGetter qual branch bs) -                getter = T.lamE [pat] expn-                  where-                    local = T.mkName "_x"-                    pat = T.varP local-                    expn = T.caseE (T.varE (T.mkName "_x")) $-                      T.match patCtor bodyCtor []-                      : rest-                      where-                        patCtor = T.conP (quald qual inner)-                          . fmap (\i -> T.varP (T.mkName $ "_y" ++ show i))-                          . take (length rules)-                          $ [(0 :: Int) ..]-                        bodyCtor = T.normalB . (T.conE 'Right `T.appE`)-                          $ case rules of-                          [] -> T.tupE []-                          _:[] -> T.varE (T.mkName "_y0")-                          _ -> T.tupE-                            . fmap (\i -> T.varE (T.mkName $ "_y" ++ show i))-                            . take (length rules)-                            $ [(0 :: Int) ..]-                        rest = case bs of-                          [] -> []-                          _ -> [T.match patBlank bodyBlank []]-                          where-                            patBlank = T.varP (T.mkName "_z")-                            bodyBlank = T.normalB-                              $ T.conE ('Left)-                              `T.appE` T.varE (T.mkName "_z")+recordLensSignature+  :: Qualifier+  -> RuleName+  -- ^ Name of the main rule+  -> RuleName+  -- ^ Name of the rule for this lens+  -> Int+  -- ^ Index for this lens+  -> T.DecQ+recordLensSignature qual nm inner idx = do+  ctorOuter <- lookupTypeName (quald qual nm)+  ctorInner <- lookupTypeName (quald qual inner)+  T.sigD lensName (forallA+    [t| Lens.Lens' ($(T.conT ctorOuter) $(typeT) $(typeA))+                  ($(T.conT ctorInner) $(typeT) $(typeA))+    |])+  where+    lensName = T.mkName $ recordFieldName idx nm inner +recordLensGetter+  :: Qualifier+  -> String+  -- ^ Record field name+  -> T.ExpQ+recordLensGetter qual fieldNm = do+  namedRec <- T.newName "_namedRec"+  fieldNm <- lookupValueName $ quald qual ('_' : fieldNm)+  let pat = T.varP namedRec+      expn = (T.varE fieldNm)+        `T.appE` (T.varE namedRec)+  T.lamE [pat] expn++recordLensSetter+  :: Qualifier+  -> String+  -- ^ Record field name+  -> T.ExpQ+recordLensSetter qual fieldNm = do+  namedRec <- T.newName "_namedRec"+  namedNewVal <- T.newName "_namedNewVal"+  fieldName <- lookupValueName (quald qual ('_' : fieldNm))+  let patRec = T.varP namedRec+      patNewVal = T.varP namedNewVal+      expn = T.recUpdE (T.varE namedRec)+        [ return (fieldName , T.VarE namedNewVal) ]+  T.lamE [patRec, patNewVal] expn++recordLensFunction+  :: Qualifier+  -> RuleName+  -- ^ Name of the main rule+  -> RuleName+  -- ^ Name of the rule for this lens+  -> Int+  -- ^ Index for this lens+  -> T.DecQ+recordLensFunction qual nm inner idx =+  let fieldNm = recordFieldName idx nm inner+      lensName = T.mkName $ recordFieldName idx nm inner+      getter = recordLensGetter qual fieldNm+      setter = recordLensSetter qual fieldNm+      body = (T.varE 'Lens.lens) `T.appE` getter `T.appE` setter+  in T.funD lensName [T.clause [] (T.normalB body) []]++ recordsToOptics   :: Qualifier   -- ^ Qualifier for module containing the data type that will get   -- optics   -> String   -- ^ Rule name-  -> Seq (Rule t)+  -> [Rule t]   -> [T.Q T.Dec]-recordsToOptics qual nm-  = concat . zipWith makeLens [(0 :: Int) ..] . toList-  where-    makeLens index (Rule inner _ _) = [ signature, function ]-      where-        charType = T.varT (T.mkName "t")-        anyType = T.varT (T.mkName "a")-        fieldNm = recordFieldName index nm inner-        lensName = T.mkName fieldNm-        signature = T.sigD lensName (forallA-          [t| Lens.Lens' ($(T.conT (quald qual nm)) $(charType) $(anyType))-                         ($(T.conT (quald qual inner)) $(charType) $(anyType))-          |])--        function = T.funD lensName [T.clause [] (T.normalB body) []]-          where-            namedRec = T.mkName "_namedRec"-            namedNewVal = T.mkName "_namedNewVal"-            body = (T.varE 'Lens.lens) `T.appE` getter `T.appE` setter-              where-                getter = T.lamE [pat] expn-                  where-                    pat = T.varP namedRec-                    expn = (T.varE (quald qual ('_' : fieldNm)))-                      `T.appE` (T.varE namedRec)--                setter = T.lamE [patRec, patNewVal] expn-                  where-                    patRec = T.varP namedRec-                    patNewVal = T.varP namedNewVal-                    expn = T.recUpdE (T.varE namedRec)-                      [ return ( quald qual ('_' : fieldNm)-                               , T.VarE namedNewVal) ]+recordsToOptics qual nm rules = do+  let makeLens index (Rule inner _ _) = [ signature, function ]+        where+          signature = recordLensSignature qual nm inner index+          function = recordLensFunction qual nm inner index+  concat . zipWith makeLens [(0 :: Int) ..] $ rules  forallA :: T.TypeQ -> T.TypeQ-forallA = T.forallT [ T.PlainTV (T.mkName "t")-                    , T.PlainTV (T.mkName "a")] (return [])+forallA = T.forallT [ tyVarBndrT, tyVarBndrA ] (return [])

@@ -1,13 +1,12 @@ {-# LANGUAGE TemplateHaskell #-} module Pinchot.SyntaxTree.Wrappers where -import Data.Foldable (toList)-import Data.Maybe (catMaybes)-import Data.Sequence (Seq)-import Data.Sequence.NonEmpty (NonEmptySeq) import qualified Control.Lens as Lens+import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (catMaybes) import qualified Language.Haskell.TH as T +import Pinchot.Names import Pinchot.Rules import Pinchot.Types @@ -28,12 +27,11 @@ -- Example: "Pinchot.Examples.SyntaxTrees".  wrappedInstances-  :: Seq (Rule t)+  :: [Rule t]   -> T.DecsQ wrappedInstances   = sequence   . catMaybes-  . toList   . fmap singleWrappedInstance   . families @@ -65,17 +63,16 @@ makeWrapped wrappedType nm = T.instanceD (return []) typ decs   where     name = T.mkName nm-    local = T.mkName "_x"     typ = (T.conT ''Lens.Wrapped) `T.appT`       ((T.conT name)-        `T.appT` (T.varT (T.mkName "t"))-        `T.appT` (T.varT (T.mkName "a")))+        `T.appT` (typeT)+        `T.appT` (typeA))     decs = [assocType, wrapper]       where         assocType = T.tySynInstD ''Lens.Unwrapped           (T.tySynEqn [T.conT name-            `T.appT` (T.varT (T.mkName "t"))-            `T.appT` (T.varT (T.mkName "a"))]+            `T.appT` (typeT)+            `T.appT` (typeA)]                       wrappedType)         wrapper = T.funD 'Lens._Wrapped'           [T.clause [] (T.normalB body) []]@@ -84,15 +81,18 @@               `T.appE` unwrap               `T.appE` doWrap               where-                unwrap = T.lamE [lambPat] (T.varE local)-                  where-                    lambPat = T.conP name [T.varP local]-                doWrap = T.lamE [lambPat] expn-                  where-                    expn = (T.conE name)-                      `T.appE` (T.varE local)-                    lambPat = T.varP local+                unwrap = do+                  local <- T.newName "_local"+                  let lambPat = T.conP name [T.varP local]+                  T.lamE [lambPat] (T.varE local)+                    +                doWrap = do+                  local <- T.newName "_local"+                  let expn = (T.conE name) `T.appE` (T.varE local)+                      lambPat = T.varP local+                  T.lamE [lambPat] expn + wrappedOpt   :: String   -- ^ Wrapped rule name@@ -104,22 +104,22 @@     maybeName = (T.conT ''Maybe)       `T.appT`       ((T.conT (T.mkName wrappedName))-        `T.appT` (T.varT (T.mkName "t"))-        `T.appT` (T.varT (T.mkName "a")))+        `T.appT` (typeT)+        `T.appT` (typeA))  wrappedTerminal   :: String   -- ^ Wrapper Rule name   -> T.Q T.Dec wrappedTerminal = makeWrapped-  [t| ( $(T.varT (T.mkName "t")), $(T.varT (T.mkName "a")) ) |]+  [t| ( $(typeT), $(typeA) ) |]  wrappedTerminals   :: String   -- ^ Wrapper Rule name   -> T.Q T.Dec wrappedTerminals = makeWrapped-  [t| Seq ( $(T.varT (T.mkName "t")), $(T.varT (T.mkName "a")) ) |]+  [t| [ ($(typeT), $(typeA)) ] |]  wrappedStar   :: String@@ -129,10 +129,9 @@   -> T.Q T.Dec wrappedStar wrappedName = makeWrapped innerName   where-    innerName = (T.conT ''Seq) `T.appT`-      ((T.conT (T.mkName wrappedName))-        `T.appT` (T.varT (T.mkName "t"))-        `T.appT` (T.varT (T.mkName "a")))+    innerName =+      [t| [ $(T.conT (T.mkName wrappedName)) $(typeT)+                                             $(typeA) ] |]  wrappedPlus   :: String@@ -142,11 +141,11 @@   -> T.Q T.Dec wrappedPlus wrappedName = makeWrapped tupName   where-    tupName = T.conT ''NonEmptySeq-      `T.appT` ((T.conT (T.mkName wrappedName))-                  `T.appT` (T.varT (T.mkName "t"))-                  `T.appT` (T.varT (T.mkName "a")))+    tupName = [t| NonEmpty ( $(T.conT (T.mkName wrappedName))+                             $(typeT)+                             $(typeA)) |] + wrappedWrap   :: String   -- ^ Wrapped rule name@@ -157,5 +156,5 @@   where     innerName =       ((T.conT (T.mkName wrappedName))-        `T.appT` (T.varT (T.mkName "t"))-        `T.appT` (T.varT (T.mkName "a")))+        `T.appT` (typeT)+        `T.appT` (typeA))

@@ -3,15 +3,14 @@ module Pinchot.Terminalize where  import Control.Monad (join)-import Data.Sequence (Seq)-import Data.Sequence.NonEmpty (NonEmptySeq)-import qualified Data.Sequence.NonEmpty as NonEmpty-import qualified Data.Sequence as Seq-import Data.Foldable (foldlM, toList)+import Data.List.NonEmpty (NonEmpty((:|)), toList)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Foldable (foldlM) import Data.Map (Map) import qualified Data.Map as Map import qualified Language.Haskell.TH as T +import Pinchot.Names import Pinchot.Types import Pinchot.Rules @@ -21,7 +20,7 @@ -- @t'RULE_NAME@ where @RULE_NAME@ is the name of the rule.  The -- type of the declaration is either ----- Production a -> Seq (t, a)+-- Production a -> [(t, a)] -- -- or --@@ -39,13 +38,12 @@   -- ^ Qualifier for the module containing the data types created   -- from the 'Rule's  -  -> Seq (Rule t)+  -> [Rule t]   -> T.Q [T.Dec]  terminalizers qual   = fmap concat   . traverse (terminalizer qual)-  . toList   . families  -- | For the given rule, creates declarations that reduce the rule@@ -54,7 +52,7 @@ -- the rule.  The -- type of the declaration is either ----- Production a -> Seq (t, a)+-- Production a -> [(t, a)] -- -- or --@@ -80,23 +78,25 @@     anyType = T.varT (T.mkName "a")     charType = T.varT (T.mkName "t")     sig-      | atLeastOne rule = T.sigD (T.mkName declName)-          . T.forallT [T.PlainTV (T.mkName "t")-                      , T.PlainTV (T.mkName "a")] (return [])-          $ [t| $(T.conT (quald qual nm)) $(charType) $(anyType)-            -> NonEmptySeq ($(charType), $(anyType)) |]-      | otherwise = T.sigD (T.mkName declName)-          . T.forallT [ T.PlainTV (T.mkName "t")-                      , T.PlainTV (T.mkName "a")] (return [])-          $ [t| $(T.conT (quald qual nm)) $(charType) $(anyType)-              -> Seq ($(charType), $(anyType)) |]+      | atLeastOne rule = do+          ctorName <- lookupTypeName (quald qual nm)+          T.sigD (T.mkName declName)+            . T.forallT [tyVarBndrT , tyVarBndrA ] (return [])+            $ [t| $(T.conT ctorName) $(charType) $(anyType)+              -> NonEmpty ($(charType), $(anyType)) |]+      | otherwise = do+          ctorName <- lookupTypeName (quald qual nm)+          T.sigD (T.mkName declName)+            . T.forallT [ tyVarBndrT , tyVarBndrA ] (return [])+            $ [t| $(T.conT ctorName) $(charType) $(anyType)+                -> [($(charType), $(anyType))] |]     expn = T.valD (T.varP $ T.mkName declName)       (T.normalB (terminalizeRuleExp qual rule)) []  -- | For the given rule, returns an expression that has type of -- either ----- Production a -> Seq (t, a)+-- Production a -> [(t, a)] -- -- or --@@ -119,7 +119,7 @@         let expn = terminalizeSingleRule qual lkp r             decName = lookupName lkp rn         in T.valD (T.varP decName) (T.normalB expn) []-  T.letE (fmap mkDec . toList $ allRules) (T.varE (lookupName lkp nm))+  T.letE (fmap mkDec $ allRules) (T.varE (lookupName lkp nm))  -- | Creates a 'Map' where each key is the name of the 'Rule' and -- each value is a name corresponding to that 'Rule'.  No@@ -145,7 +145,7 @@ -- | For the given rule, returns an expression that has type -- of either ----- Production a -> Seq (t, a)+-- Production a -> [(t, a)] -- -- or --@@ -168,8 +168,9 @@ terminalizeSingleRule qual lkp rule@(Rule nm _ ty) = case ty of   Terminal _ -> do     x <- T.newName "x"-    let pat = T.conP (quald qual nm) [T.varP x]-    [| \ $(pat) -> NonEmpty.singleton $(T.varE x) |]+    ctorName <- lookupValueName (quald qual nm)+    let pat = T.conP ctorName [T.varP x]+    [| \ $(pat) -> ( $(T.varE x) :| [] ) |]    NonTerminal bs -> do     x <- T.newName "x"@@ -183,7 +184,8 @@    Wrap (Rule inner _ _) -> do     x <- T.newName "x"-    let pat = T.conP (quald qual nm) [T.varP x]+    ctorName <- lookupValueName (quald qual nm)+    let pat = T.conP ctorName [T.varP x]     [| \ $(pat) -> $(T.varE (lookupName lkp inner)) $(T.varE x) |]    Record rs -> do@@ -195,17 +197,19 @@    Opt r@(Rule inner _ _) -> do     x <- T.newName "x"-    let pat = T.conP (quald qual nm) [T.varP x]-    [| \ $(pat) -> maybe Seq.empty+    ctorName <- lookupValueName (quald qual nm)+    let pat = T.conP ctorName [T.varP x]+    [| \ $(pat) -> maybe []            $(convert (T.varE (lookupName lkp inner))) $(T.varE x) |]     where-      convert expn | atLeastOne r = [| NonEmpty.nonEmptySeqToSeq . $(expn) |]+      convert expn | atLeastOne r = [| NonEmpty.toList . $(expn) |]                    | otherwise = expn    Star r@(Rule inner _ _) -> do     x <- T.newName "x"-    let pat = T.conP (quald qual nm) [T.varP x]-        convert e | atLeastOne r = [| NonEmpty.nonEmptySeqToSeq . $(e) |]+    ctorName <- lookupValueName (quald qual nm)+    let pat = T.conP ctorName [T.varP x]+        convert e | atLeastOne r = [| NonEmpty.toList . $(e) |]                   | otherwise = e     [| \ $(pat) -> join . fmap $(convert (T.varE (lookupName lkp inner)))           $ $(T.varE x) |]@@ -213,26 +217,28 @@   Plus r@(Rule inner _ _)     | atLeastOne r -> do         x <- T.newName "x"-        let pat = T.conP (quald qual nm) [T.varP x]+        ctorName <- lookupValueName (quald qual nm)+        let pat = T.conP ctorName [T.varP x]         [| \ $(pat) ->             let getTermNonEmpty = $(T.varE (lookupName lkp inner))-                getTerms (NonEmpty.NonEmptySeq e1 es)+                getTerms (e1 :| es)                   = join . fmap getTermNonEmpty-                  $ NonEmpty.NonEmptySeq e1 es+                  $ (e1 :| es)            in getTerms $(T.varE x)           |]      | otherwise -> do         x <- T.newName "x"         [| let getTermSeq = $(T.varE (lookupName lkp inner))-               getTerms (NonEmpty.NonEmptySeq e1 es) = getTermSeq e1+               getTerms (e1 :| es) = getTermSeq e1                 `mappend` (join (fmap getTermSeq es))            in getTerms $(T.varE x)           |]    Series _ -> do     x <- T.newName "x"-    let pat = T.conP (quald qual nm) [T.varP x]+    ctorName <- lookupValueName (quald qual nm)+    let pat = T.conP ctorName [T.varP x]     [| \ $(pat) -> $(T.varE x) |]  terminalizeProductAllowsZero@@ -240,51 +246,60 @@   -> Map RuleName T.Name   -> String   -- ^ Rule name or branch name, as applicable-  -> Seq (Rule t)+  -> [Rule t]   -> T.Q (T.PatQ, T.ExpQ) terminalizeProductAllowsZero qual lkp name bs = do-  pairs <- fmap toList . traverse (terminalizeProductRule lkp) $ bs-  let pat = T.conP (quald qual name) (fmap (fst . snd) pairs)+  pairs <- traverse (terminalizeProductRule lkp) $ bs+  ctorName <- lookupValueName (quald qual name)+  let pat = T.conP ctorName (fmap (fst . snd) pairs)       body = case pairs of-        [] -> [| Seq.empty |]+        [] -> [| [] |]         x:xs -> foldl f start xs           where             f acc trip = [| $(acc) `mappend` $(procTrip trip) |]             start = procTrip x             procTrip (rule, (_, expn))-              | atLeastOne rule = [| NonEmpty.nonEmptySeqToSeq $(expn) |]+              | atLeastOne rule = [| NonEmpty.toList $(expn) |]               | otherwise = expn   return (pat, body) +prependList :: [a] -> NonEmpty a -> NonEmpty a+prependList [] ne = ne+prependList (x:xs) (a :| as) = (x :| (xs ++ (a : as)))++appendList :: NonEmpty a -> [a] -> NonEmpty a+appendList (a :| as) xs = a :| (as ++ xs)+ terminalizeProductAtLeastOne   :: Qualifier   -> Map RuleName T.Name   -> String   -- ^ Rule name or branch name, as applicable-  -> Seq (Rule t)+  -> [Rule t]   -> T.Q (T.PatQ, T.ExpQ) terminalizeProductAtLeastOne qual lkp name bs = do-  pairs <- fmap toList . traverse (terminalizeProductRule lkp) $ bs-  let pat = T.conP (quald qual name) (fmap (fst . snd) pairs)-      body = [| ( $(leadSeq) `NonEmpty.prependSeq` $(firstNonEmpty))-                `NonEmpty.appendSeq` $(trailSeq) |]+  pairs <- traverse (terminalizeProductRule lkp) $ bs+  ctorName <- lookupValueName (quald qual name)+  let pat = T.conP ctorName (fmap (fst . snd) pairs)+      body = [| ( $(leadSeq) `prependList` $(firstNonEmpty))+                `appendList` $(trailSeq) |]         where           (leadRules, lastRules) = span (not . atLeastOne . fst) pairs           (firstNonEmptyRule, trailRules) = case lastRules of             [] -> error $ "terminalizeProductAtLeastOne: failure 1: " ++ name             x:xs -> (x, xs)           leadSeq = case fmap (snd . snd) leadRules of-            [] -> [| Seq.empty |]+            [] -> [| [] |]             x:xs -> foldl f x xs               where                 f acc expn = [| $(acc) `mappend` $(expn) |]           firstNonEmpty = [| $(snd . snd $ firstNonEmptyRule) |] -          trailSeq = foldl f [| Seq.empty |] trailRules+          trailSeq = foldl f [| [] |] trailRules             where               f acc (rule, (_, expn))                 | atLeastOne rule =-                    [| $(acc) `mappend` NonEmpty.nonEmptySeqToSeq $(expn) |]+                    [| $(acc) `mappend` NonEmpty.toList $(expn) |]                 | otherwise =                     [| $(acc) `mappend` $(expn) |]   return (pat, body)

@@ -4,13 +4,10 @@ {-# LANGUAGE DeriveAnyClass #-} module Pinchot.Types where -import Pinchot.Intervals- import qualified Control.Lens as Lens import Data.Data (Data)+import Data.List.NonEmpty (NonEmpty) import GHC.Generics (Generic)-import Data.Sequence (Seq)-import Data.Sequence.NonEmpty (NonEmptySeq) import qualified Language.Haskell.TH as T import Text.Show.Pretty (PrettyVal(prettyVal)) import qualified Text.Show.Pretty as Pretty@@ -50,7 +47,7 @@   { _ruleName :: RuleName   , _ruleDescription :: Maybe String   , _ruleType :: RuleType t-  } deriving (Eq, Ord, Show, Data, Generic, PrettyVal)+  } deriving (Show, Generic, PrettyVal)  -- Can't use Template Haskell in this module due to corecursive -- types@@ -72,40 +69,50 @@ -- produces. data Branch t = Branch   { _branchName :: BranchName-  , _branches :: Seq (Rule t)-  } deriving (Eq, Ord, Show, Data)+  , _branches :: [Rule t]+  } deriving (Show, Generic, PrettyVal)  branchName :: Lens.Lens' (Branch t) BranchName branchName   = Lens.lens _branchName (\b n -> b { _branchName = n }) -branches :: Lens.Lens' (Branch t) (Seq (Rule t))+branches :: Lens.Lens' (Branch t) [Rule t] branches   = Lens.lens _branches (\b s -> b { _branches = s}) -instance PrettyVal t => PrettyVal (Branch t) where-  prettyVal (Branch b1 bs) = Pretty.Rec "Branch"-    [ ("_branchName", prettyVal b1)-    , ("_branches", prettySeq prettyVal bs)-    ]+newtype Predicate a = Predicate { unPredicate :: T.Q (T.TExp (a -> Bool)) } +instance Show (Predicate a) where show _ = "<predicate>"+instance PrettyVal (Predicate a) where prettyVal _ = Pretty.Con "Predicate" []+ -- | The type of a particular rule. data RuleType t-  = Terminal (Intervals t)-  | NonTerminal (NonEmptySeq (Branch t))+  = Terminal (Predicate t)+  | NonTerminal (NonEmpty (Branch t))   | Wrap (Rule t)-  | Record (Seq (Rule t))+  | Record [Rule t]   | Opt (Rule t)   | Star (Rule t)   | Plus (Rule t)-  | Series (NonEmptySeq t)-  deriving (Eq, Ord, Show, Data)+  | Series (NonEmpty t)+  deriving (Show, Generic) -_Terminal :: Lens.Prism' (RuleType t) (Intervals t)-_Terminal = Lens.prism' Terminal-  (\r -> case r of { Terminal i -> Just i; _ -> Nothing })+instance PrettyVal t => PrettyVal (RuleType t) where+  prettyVal r = case r of+    Terminal t -> Pretty.Con "Terminal" [prettyVal t]+    NonTerminal ne -> Pretty.Con "NonTerminal" [prettyNonEmpty prettyVal ne]+    Wrap r -> Pretty.Con "Wrap" [prettyVal r]+    Record rs -> Pretty.Con "Record" [Pretty.List $ fmap prettyVal rs]+    Opt r -> Pretty.Con "Opt" [prettyVal r]+    Star r -> Pretty.Con "Star" [prettyVal r]+    Plus r -> Pretty.Con "Plus" [prettyVal r]+    Series ne -> Pretty.Con "Series" [prettyNonEmpty prettyVal ne] -_NonTerminal :: Lens.Prism' (RuleType t) (NonEmptySeq (Branch t))+_Terminal :: Lens.Prism' (RuleType t) (T.Q (T.TExp (t -> Bool)))+_Terminal = Lens.prism' (Terminal . Predicate)+  (\r -> case r of { Terminal (Predicate i) -> Just i; _ -> Nothing })++_NonTerminal :: Lens.Prism' (RuleType t) (NonEmpty (Branch t)) _NonTerminal = Lens.prism' NonTerminal   (\r -> case r of { NonTerminal b -> Just b; _ -> Nothing }) @@ -113,7 +120,7 @@ _Wrap = Lens.prism' Wrap   (\r -> case r of { Wrap x -> Just x; _ -> Nothing }) -_Record :: Lens.Prism' (RuleType t) (Seq (Rule t))+_Record :: Lens.Prism' (RuleType t) [Rule t] _Record = Lens.prism' Record   (\r -> case r of { Record x -> Just x; _ -> Nothing }) @@ -129,22 +136,10 @@ _Plus = Lens.prism' Plus   (\r -> case r of { Plus x -> Just x; _ -> Nothing }) -_Series :: Lens.Prism' (RuleType t) (NonEmptySeq t)+_Series :: Lens.Prism' (RuleType t) (NonEmpty t) _Series = Lens.prism' Series   (\r -> case r of { Series s -> Just s; _ -> Nothing }) -instance PrettyVal t => PrettyVal (RuleType t) where-  prettyVal x = case x of-    Terminal ivl -> Pretty.Con "Terminal" [(prettyVal ivl)]-    NonTerminal ne -> Pretty.Con "NonTerminal"-      [prettyNonEmptySeq prettyVal ne]-    Wrap r -> Pretty.Con "Wrap" [prettyVal r]-    Record rs -> Pretty.Con "Record" [prettySeq prettyVal rs]-    Opt rs -> Pretty.Con "Opt" [prettyVal rs]-    Star rs -> Pretty.Con "Star" [prettyVal rs]-    Plus rs -> Pretty.Con "Plus" [prettyVal rs]-    Series sq -> Pretty.Con "Series" [prettyNonEmptySeq prettyVal sq]- -- | The name of a field in a record, without the leading -- underscore. recordFieldName@@ -156,44 +151,6 @@   -- ^ Inner type name   -> String recordFieldName idx par inn = "r'" ++ par ++ "'" ++ show idx ++ "'" ++ inn---- | Many functions take an argument that holds the name qualifier--- for the module that contains the data types created by applying a--- function such as 'Pinchot.SyntaxTree.syntaxTrees' or--- 'Pinchot.Earley.earleyProduct'.------ You will have to make sure that these data types are in scope.--- The spliced Template Haskell code has to know where to--- look for these data types.  If you did an unqualified @import@ or--- if the types are in the same module as the function that takes a--- 'Qualifier' argument, just pass the empty string here.  If you did a--- qualified import, use the appropriate qualifier here.------ For example, if you used @import qualified MyAst@, pass--- @\"MyAst\"@ here.  If you used @import qualified--- Data.MyLibrary.MyAst as MyLibrary.MyAst@, pass--- @\"MyLibrary.MyAst\"@ here.------ I recommend that you always create a new module and that all you--- do in that module is apply 'Pinchot.SyntaxTree.syntaxTrees' or--- 'Pinchot.Earley.earleyProduct', and that you then perform an @import--- qualified@ to bring those names into scope in the module in which--- you use a function that takes a 'Qualifier' argument.  This--- avoids unlikely, but possible, issues that could otherwise arise--- due to naming conflicts.-type Qualifier = String----- | Prepends a qualifier to a string, and returns the resulting--- Name.-quald-  :: Qualifier-  -> String-  -- ^ Item to be named - constructor, value, etc.-  -> T.Name-quald qual suf-  | null qual = T.mkName suf-  | otherwise = T.mkName (qual ++ '.':suf)  -- | A location. 

@@ -3,16 +3,16 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: gen-pinchot-cabal--- Generated on: 2016-08-21 08:12:40.469343 EDT+-- Generated on: 2017-02-03 16:36:31.080916 EST -- Cartel library version: 0.16.0.0  name: pinchot-version: 0.22.0.0+version: 0.24.0.0 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE build-type: Simple-copyright: Copyright (c) 2015 - 2016 Omari Norman+copyright: Copyright (c) 2015 - 2017 Omari Norman author: Omari Norman maintainer: omari@smileystation.com stability: Experimental@@ -34,9 +34,7 @@     , Earley >= 0.11.0.1     , pretty-show >= 1.6.9     , lens >= 4.13-    , ListLike >= 4.2.1     , semigroups >= 0.18.1-    , non-empty-sequence >= 0.2   exposed-modules:     Pinchot     Pinchot.Earley@@ -48,8 +46,8 @@     Pinchot.Examples.RulesToOptics     Pinchot.Examples.SyntaxTrees     Pinchot.Examples.Terminalize-    Pinchot.Intervals     Pinchot.Locator+    Pinchot.Names     Pinchot.Pretty     Pinchot.RecursiveDo     Pinchot.Rules@@ -86,9 +84,7 @@       , Earley >= 0.11.0.1       , pretty-show >= 1.6.9       , lens >= 4.13-      , ListLike >= 4.2.1       , semigroups >= 0.18.1-      , non-empty-sequence >= 0.2     other-modules:       Pinchot       Pinchot.Earley@@ -100,8 +96,8 @@       Pinchot.Examples.RulesToOptics       Pinchot.Examples.SyntaxTrees       Pinchot.Examples.Terminalize-      Pinchot.Intervals       Pinchot.Locator+      Pinchot.Names       Pinchot.Pretty       Pinchot.RecursiveDo       Pinchot.Rules@@ -135,9 +131,7 @@       , Earley >= 0.11.0.1       , pretty-show >= 1.6.9       , lens >= 4.13-      , ListLike >= 4.2.1       , semigroups >= 0.18.1-      , non-empty-sequence >= 0.2     other-modules:       Pinchot       Pinchot.Earley@@ -149,8 +143,8 @@       Pinchot.Examples.RulesToOptics       Pinchot.Examples.SyntaxTrees       Pinchot.Examples.Terminalize-      Pinchot.Intervals       Pinchot.Locator+      Pinchot.Names       Pinchot.Pretty       Pinchot.RecursiveDo       Pinchot.Rules