pinchot 0.18.2.0 → 0.20.0.0

raw patch · 23 files changed

+475/−268 lines, 23 filesdep +non-empty-sequencedep +pretty-showdep ~basedep ~template-haskellnew-component:exe:newmanPrettyPVP ok

version bump matches the API change (PVP)

Dependencies added: non-empty-sequence, pretty-show

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• LICENSE +10/−12
• README +0/−8
• README.md +14/−0
• exe/newmanPretty.hs +9/−0
• lib/Pinchot.hs +1/−12
• lib/Pinchot/Earley.hs +8/−7
• lib/Pinchot/Examples.hs +8/−0
• lib/Pinchot/Examples/Newman.hs +14/−7
• lib/Pinchot/Examples/SyntaxTrees.hs +3/−0
• lib/Pinchot/Examples/Terminalize.hs +3/−1
• lib/Pinchot/Intervals.hs +11/−0
• lib/Pinchot/NonEmpty.hs +0/−68
• lib/Pinchot/Pretty.hs +56/−0
• lib/Pinchot/Rules.hs +6/−10
• lib/Pinchot/SyntaxTree.hs +24/−19
• lib/Pinchot/SyntaxTree/Instancer.hs +172/−2
• lib/Pinchot/SyntaxTree/Optics.hs +4/−5
• lib/Pinchot/SyntaxTree/Wrappers.hs +2/−2
• lib/Pinchot/Terminalize.hs +14/−14
• lib/Pinchot/Types.hs +31/−6
• newTemplateHaskell/Pinchot/Internal/TemplateHaskellShim.hs +0/−18
• oldTemplateHaskell/Pinchot/Internal/TemplateHaskellShim.hs +0/−15
• pinchot.cabal +85/−62

@@ -1,24 +1,22 @@-Copyright (c) 2015 Omari Norman.+Copyright (c) 2016 Omari Norman All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -    * Redistributions of source code must retain the above copyright-    notice, this list of conditions and the following disclaimer.+1. Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer. -    * Redistributions in binary form must reproduce the above copyright-    notice, this list of conditions and the following disclaimer in-    the documentation and/or other materials provided with the-    distribution.+2. Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution. -    * Neither the name of Omari Norman nor the names of contributors-    to this software may be used to endorse or promote products-    derived from this software without specific prior written-    permission.+3. Neither the name of the copyright holder nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

@@ -1,8 +0,0 @@-Pinchot helps you build Haskell data types and parsers-corresponding to a context-free grammar.--Documentation is contained in the Haddock markup in the-source files.--Pinchot is licensed under the BSD license; see the-LICENSE file.

@@ -0,0 +1,14 @@+# pinchot++Pinchot helps you build Haskell data types and parsers+corresponding to a context-free grammar.++## License++This package is released under the BSD3 license. Please see the LICENSE file.++## Building this project++If you are viewing the source code repository, a `.cabal` file might+not be included.  Please see the README.md in the main project directory+for details on how to generate the `.cabal` file.

@@ -0,0 +1,9 @@+module Main where++import Pinchot.Examples.Newman+import System.Environment (getArgs)++main :: IO ()+main = do+  a1:[] <- getArgs+  addressPretty a1

@@ -47,17 +47,6 @@   , solo   , pariah -  -- * Non-empty-  , NonEmpty(..)-  , front-  , rest-  , flatten-  , seqToNonEmpty-  , prependSeq-  , appendSeq-  , append-  , singleton-     -- * Production rules   , RuleName   , Rule@@ -88,6 +77,7 @@   , bifunctorInstances   , semigroupInstances   , monoidInstances+  , prettyInstances   , rulesToOptics    -- * Creating Earley grammars@@ -113,7 +103,6 @@ import Pinchot.Earley import Pinchot.Locator import Pinchot.Intervals-import Pinchot.NonEmpty import Pinchot.Rules import Pinchot.SyntaxTree import Pinchot.SyntaxTree.Instancer

@@ -4,7 +4,6 @@  module Pinchot.Earley where -import Pinchot.NonEmpty import Pinchot.RecursiveDo import Pinchot.Rules import Pinchot.Types@@ -12,10 +11,11 @@  import Control.Applicative ((<|>), liftA2) 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 qualified Language.Haskell.TH as T-import Pinchot.Internal.TemplateHaskellShim (dataD) import qualified Language.Haskell.TH.Syntax as Syntax import qualified Text.Earley @@ -40,7 +40,7 @@                 | otherwise = Nothing            in Text.Earley.terminal f |] -  NonTerminal b1 bs -> [makeRule expression]+  NonTerminal (NE.NonEmptySeq b1 bs) -> [makeRule expression]     where       expression = foldl addBranch (branchToParser prefix b1) bs         where@@ -85,7 +85,7 @@               pSeq = [| (<|) <$> $(T.varE (localRuleName innerNm))                              <*> $(T.varE helper) |]       topExpn = [| $constructor <$>-        ( NonEmpty <$> $(T.varE (localRuleName innerNm))+        ( NonEmptySeq <$> $(T.varE (localRuleName innerNm))                    <*> $(T.varE helper)) |]  @@ -177,17 +177,18 @@   -- where @NAME@ is the name of the type.  Don't count on these   -- records being in any particular order. allRulesRecord prefix ruleSeq-  = sequence [dataD (return []) (T.mkName nameStr) tys [con] []]+  = sequence [T.dataD (return []) (T.mkName nameStr)+                      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.varStrictType recName st+    mkRecord (Rule ruleNm _ _) = T.varBangType recName st       where         recName = T.mkName ("a'" ++ ruleNm)-        st = T.strictType T.notStrict ty+        st = T.bangType (T.bang T.noSourceUnpackedness T.noSourceStrictness) ty           where             ty = [t| Text.Earley.Prod $(T.varT (T.mkName "r"))                       String

@@ -24,5 +24,13 @@ -- compile the Pinchot package using the @executables@ flag, you -- will get an executable named @newman@ that you can play with from -- the command line.+--+-- Similar to the 'Pinchot.Examples.Newman.address' is+-- 'Pinchot.Examples.Newman.addressPretty'; the difference is that+-- 'Pinchot.Examples.Newman.addressPretty' uses the pretty printer+-- from the @pretty-show@ package, while+-- 'Pinchot.Examples.Newman.address' uses a hand-written+-- pretty printer.  The @newmanPretty@ address uses+-- 'Pinchot.Examples.Newman.addressPretty'.  module Pinchot.Examples where

@@ -5,6 +5,7 @@ module Pinchot.Examples.Newman where  import Pinchot+import Pinchot.Pretty  import Pinchot.Examples.Earley import Pinchot.Examples.SyntaxTrees@@ -16,7 +17,10 @@ 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 qualified Text.Earley as Earley+import qualified Text.Show.Pretty as Pretty  -- | Formats a 'Loc' for nice on-screen display. labelLoc :: Loc -> String@@ -37,12 +41,12 @@  -- | Labels a single field, where the field will always appear in a -- parsed result.-labelNE :: String -> NonEmpty (Char, Loc) -> String+labelNE :: String -> NonEmptySeq (Char, Loc) -> String labelNE l sq   = l ++ ": " ++ show (toList . fmap fst $ sq)   ++ " " ++ loc ++ "\n"   where-    loc = labelLoc . snd . _front $ sq+    loc = labelLoc . snd . NE._fore $ sq  -- | Formats a single 'Address' for nice on-screen display. showAddress :: Address Char Loc -> String@@ -56,7 +60,7 @@           . _r'Address'1'StreetLine $ a          pre = labelOpt "Direction prefix"-          . maybe Seq.empty flatten+          . maybe Seq.empty NE.nonEmptySeqToSeq           . Lens.preview (r'Address'1'StreetLine                           . r'StreetLine'2'DirectionSpace'Opt                           . Lens._Wrapped'@@ -72,7 +76,7 @@           $ a          suf = labelOpt "Street suffix"-          . maybe Seq.empty flatten+          . maybe Seq.empty NE.nonEmptySeqToSeq           . Lens.preview (r'Address'1'StreetLine                           . r'StreetLine'4'SpaceSuffix'Opt                           . Lens._Wrapped'@@ -119,12 +123,15 @@ address :: String -> IO () address = putStrLn . showParseResult . locatedFullParses addressGrammar +-- | Like 'address' but uses 'Pretty.valToStr'.+addressPretty :: String -> IO ()+addressPretty = putStrLn . Pretty.valToStr+  . prettyFullParses . locatedFullParses addressGrammar+ -- | Read an address from a file and print the resulting report. -- Good for use in GHCi. addressFromFile   :: String   -- ^ Filename   -> IO ()-addressFromFile fn = do-  str <- readFile fn-  putStrLn . showParseResult . locatedFullParses addressGrammar $ str+addressFromFile fn = readFile fn >>= address

@@ -33,3 +33,6 @@  -- This generates instances of the Monoid typeclass. $(monoidInstances [rAddress])++-- This generates instances of the 'Pretty.PrettyVal' typeclass.+$(prettyInstances [rAddress])

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

@@ -17,7 +17,11 @@ 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@@ -35,6 +39,13 @@   } 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)

@@ -1,68 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-{-# LANGUAGE DeriveDataTypeable #-}--- | Sequences that always contain at least one element.--module Pinchot.NonEmpty where--import Control.Monad (join, ap)-import Data.Data (Data)-import Data.Semigroup (Semigroup((<>)))-import Data.Sequence (Seq, (<|))-import qualified Data.Sequence as Seq-import qualified Control.Lens as Lens---- | A non-empty sequence.-data NonEmpty a = NonEmpty-  { _front :: a-  -- ^ The first item-  , _rest :: Seq a-  -- ^ All remaining items-  } deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable)--instance Semigroup (NonEmpty a) where-  (NonEmpty a1 as) <> (NonEmpty b1 bs)-    = NonEmpty a1 (as <> (b1 <| bs))--Lens.makeLenses ''NonEmpty---- | Convert a 'NonEmpty' to a 'Seq'.-flatten :: NonEmpty a -> Seq a-flatten (NonEmpty a as) = a <| as--instance Monad NonEmpty where-  return a = NonEmpty a Seq.empty-  NonEmpty a as >>= f = NonEmpty (_front r1) rs-    where-      r1 = f a-      rs = _rest r1 `mappend` rss-      rss = join . fmap flatten . fmap f $ as--instance Applicative NonEmpty where-  pure = return-  (<*>) = ap---- | Converts a non-empty 'Seq' to a 'NonEmpty'; 'Nothing' if the--- 'Seq' is empty.-seqToNonEmpty :: Seq a -> Maybe (NonEmpty a)-seqToNonEmpty = fmap (uncurry NonEmpty) . Lens.uncons---- | Prepends a 'Seq' to a 'NonEmpty'.-prependSeq :: Seq a -> NonEmpty a -> NonEmpty a-prependSeq sq (NonEmpty a as) = case Lens.uncons sq of-  Nothing -> NonEmpty a as-  Just (l, ls) -> NonEmpty l (ls `mappend` (a <| as))---- | Appends a 'Seq' to a 'NonEmpty'.-appendSeq :: NonEmpty a -> Seq a -> NonEmpty a-appendSeq (NonEmpty a as) sq = NonEmpty a (as `mappend` sq)---- | Associative operation that appends to 'NonEmpty'.-append :: NonEmpty a -> NonEmpty a -> NonEmpty a-append (NonEmpty l1 ls) (NonEmpty r1 rs)-  = NonEmpty l1 (ls `mappend` (r1 <| rs))---- | Place a single item at the head of the 'NonEmpty'.-singleton :: a -> NonEmpty a-singleton a = NonEmpty a Seq.empty

@@ -0,0 +1,56 @@+-- | Pretty printing.++module Pinchot.Pretty where++import Data.Foldable (toList)+import Data.Sequence (Seq)+import Data.Sequence.NonEmpty (NonEmptySeq(NonEmptySeq))+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++-- | 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 'Maybe'.+prettyMaybe+  :: (a -> Value)+  -> Maybe a+  -> Value+prettyMaybe _ Nothing = Pretty.Con "Nothing" []+prettyMaybe f (Just a) = Pretty.Con "Just" [f a]++-- | Prettify a 'Report'.+prettyReport+  :: (e -> Value)+  -> (i -> Value)+  -> Earley.Report e i+  -> Value+prettyReport fe fi (Earley.Report p e i) = Pretty.Rec "Report"+  [ ("position", Pretty.prettyVal p)+  , ("expected", Pretty.List (map fe e))+  , ("unconsumed", fi i)+  ]++-- | Prettify the output of 'Pinchot.Locator.locatedFullParses'.+prettyFullParses+  :: (Pretty.PrettyVal p, Pretty.PrettyVal v)+  => ([p], Earley.Report String (Seq v))+  -> Value+prettyFullParses x = Pretty.Tuple+  [ Pretty.prettyVal . fst $ x+  , prettyReport Pretty.prettyVal (prettySeq Pretty.prettyVal)+      . snd $ x+  ]

@@ -2,13 +2,12 @@ {-# LANGUAGE OverloadedLists #-} module Pinchot.Rules where -import qualified Control.Lens as Lens import Control.Monad (join) import Control.Monad.Trans.State (get, put, State) import qualified Control.Monad.Trans.State as State-import Data.Monoid ((<>)) import Data.Sequence (Seq, (<|)) import qualified Data.Sequence as Seq+import qualified Data.Sequence.NonEmpty as NE import Data.Set (Set) import qualified Data.Set as Set @@ -53,11 +52,9 @@   -- must have at least one element; otherwise, an error will   -- result.   -> Rule t-nonTerminal n branches = case Lens.uncons branches of+nonTerminal n branches = case NE.seqToNonEmptySeq branches of   Nothing -> error $ "nonTerminal: rule has no branches: " ++ n-  Just (b, bs) -> rule n (NonTerminal (f b) (fmap f bs))-    where-      f = uncurry Branch+  Just bs -> rule n . NonTerminal . fmap (uncurry Branch) $ bs  -- | Creates a non-terminal production rule where each branch has -- only one production.  This function ultimately uses@@ -183,10 +180,9 @@       put (Set.insert name set)       case ty of         Terminal _ -> return (Seq.singleton r)-        NonTerminal b1 bs -> do-          as1 <- branchAncestors b1-          ass <- fmap join . traverse branchAncestors $ bs-          return $ r <| as1 <> ass+        NonTerminal bs -> do+          ass <- fmap join . traverse branchAncestors . NE.nonEmptySeqToSeq $ bs+          return $ r <| ass         Wrap c -> do           cs <- getAncestors c           return $ r <| cs

@@ -6,10 +6,9 @@  import Data.Foldable (toList) import Data.Sequence (Seq)+import Data.Sequence.NonEmpty (NonEmptySeq) import qualified Language.Haskell.TH as T-import Pinchot.Internal.TemplateHaskellShim (newtypeD, dataD) -import Pinchot.NonEmpty import Pinchot.Rules import Pinchot.Types @@ -32,8 +31,11 @@ branchConstructor (Branch nm rules) = T.normalC name fields   where     name = T.mkName nm-    mkField (Rule n _ _) = T.strictType T.notStrict+    mkField (Rule n _ _) = notStrict       [t| $(T.conT (T.mkName n)) $(charTypeVar) $(anyTypeVar) |]+      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")@@ -44,57 +46,57 @@   -- ^ What to derive   -> Rule t   -> T.Q T.Dec-ruleToType derives (Rule nm _ ruleType) = case ruleType of+ruleToType deriveNames (Rule nm _ ruleType) = case ruleType of   Terminal _ ->-    newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives     where       newtypeCon = T.normalC name-        [T.strictType T.notStrict+        [notStrict           [t| ( $(charTypeVar), $(anyTypeVar) ) |] ] -  NonTerminal b1 bs -> dataD (T.cxt []) name [charType, anyType] cons derives+  NonTerminal bs -> T.dataD (T.cxt []) name [charType, anyType] Nothing cons derives     where-      cons = branchConstructor b1 : toList (fmap branchConstructor bs)+      cons = toList (fmap branchConstructor bs)    Wrap (Rule inner _ _) ->-    newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives     where       newtypeCon = T.normalC name-        [ T.strictType T.notStrict+        [ notStrict             [t| $(T.conT (T.mkName inner)) $(charTypeVar) $(anyTypeVar) |] ] -  Record sq -> dataD (T.cxt []) name [charType, anyType] [ctor] derives+  Record sq -> T.dataD (T.cxt []) name [charType, anyType] Nothing [ctor] derives     where       ctor = T.recC name . zipWith mkField [(0 :: Int) ..] . toList $ sq-      mkField num (Rule rn _ _) = T.varStrictType (T.mkName fldNm)-        (T.strictType T.notStrict+      mkField num (Rule rn _ _) = T.varBangType (T.mkName fldNm)+        (notStrict           [t| $(T.conT (T.mkName rn)) $(charTypeVar) $(anyTypeVar) |])         where           fldNm = '_' : recordFieldName num nm rn    Opt (Rule inner _ _) ->-    newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives     where       newtypeCon = T.normalC name-        [T.strictType T.notStrict+        [notStrict           [t| Maybe ( $(T.conT (T.mkName inner)) $(charTypeVar)                                                  $(anyTypeVar)) |]]    Star (Rule inner _ _) ->-    newtypeD (T.cxt []) name [charType, anyType] newtypeCon derives+    T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives     where       newtypeCon = T.normalC name [sq]         where-          sq = T.strictType T.notStrict+          sq = notStrict             [t| Seq ( $(T.conT (T.mkName inner)) $(charTypeVar)                                                  $(anyTypeVar) ) |]    Plus (Rule inner _ _) ->-    newtypeD (T.cxt []) name [charType, anyType] cons derives+    T.newtypeD (T.cxt []) name [charType, anyType] Nothing cons derives     where       cons = T.normalC name [ne]         where-          ne = T.strictType T.notStrict [t| NonEmpty $(ins) |]+          ne = notStrict [t| NonEmptySeq $(ins) |]             where               ins = [t| $(T.conT (T.mkName inner))                 $(charTypeVar) $(anyTypeVar) |]@@ -105,5 +107,8 @@     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)  

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} module Pinchot.SyntaxTree.Instancer where +import Control.Monad (replicateM) import qualified Data.Bifunctor as Bifunctor import Data.Maybe (catMaybes) import qualified Data.Semigroup as Semigroup@@ -13,9 +14,12 @@ import Data.Semigroup ((<>)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq+import Data.Sequence.NonEmpty (NonEmptySeq) import qualified Language.Haskell.TH as T+import qualified Text.Show.Pretty as Pretty  import Pinchot.Types+import Pinchot.Pretty import Pinchot.Rules  -- | Creates an instance of 'Bifunctor.Bifunctor' for every 'Rule'@@ -148,8 +152,8 @@   -> T.Q T.DecQ bimapLetBind qual fa fb lkp (Rule name _ ty) = case ty of   Terminal _ -> terminalBimapLetBind qual fa fb lkp name-  NonTerminal b1 bs -> return $ nonTerminalBimapLetBind qual lkp name-    (b1 : toList bs)+  NonTerminal bs -> return $ nonTerminalBimapLetBind qual lkp name+    (toList bs)   Wrap (Rule inner _ _) -> wrapBimapLetBind qual lkp name inner   Record sq -> recordBimapLetBind qual lkp name sq   Opt (Rule inner _ _) -> optBimapLetBind qual lkp name inner@@ -400,3 +404,169 @@           [| $(T.varE append) $(T.varE x1) $(T.varE x2) |] rules           where             f rule acc = T.appE (T.conE (quald qual rule)) acc++-- | Creates an expression of type+--+-- RuleData -> Value+prettyExpression+  :: Qualifier+  -> Rule t+  -> T.ExpQ+prettyExpression qual rule@(Rule name _ _) = do+  lkp <- nameMap rule+  thisRule <- lookupRule lkp name+  let decs = map mkDec . toList . family $ rule+        where+          mkDec inner = do+            innerNm <- lookupRule lkp (_ruleName inner)+            T.valD (T.varP innerNm)+              (T.normalB (prettyExpressionInEnv qual lkp inner)) []+  T.letE decs (T.varE thisRule)++-- | Creates a 'Pretty.PrettyVal' instance.  This must be spliced into the same+-- module in which the corresponding data type is spliced.+prettyInstance+  :: 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 |]+            ]+      ty = [t| Pretty.PrettyVal ( $ruleTypeName $t $a ) |]+      dec = T.funD 'Pretty.prettyVal [clause]+        where+          clause = T.clause [] (T.normalB (prettyExpression "" rule)) []+  T.instanceD (T.cxt cxt) ty [dec]++-- | Creates a 'Pretty.PrettyVal' instance for a rule and all its+-- ancestors.+prettyInstanceFamily+  :: Rule t+  -> T.DecsQ+prettyInstanceFamily+  = fmap toList . sequence . fmap prettyInstance . family++-- | Creates a 'Pretty.PrettyVal' instance for each 'Rule' in the+-- 'Seq', as well as for all the ancestors of each 'Rule' in the+-- 'Seq'.+--+-- This function must be+-- spliced in the same module as the module in which the syntax tree+-- types are created.  This avoids problems with orphan instances.+-- Since ancestors are included, you can get the entire tree of+-- instances that you need by applying this function to a single+-- start symbol.+--+-- Example: "Pinchot.Examples.SyntaxTrees".+prettyInstances+  :: Seq (Rule t)+  -> T.DecsQ+prettyInstances+  = fmap toList . sequence . fmap prettyInstance . families++-- | Creates an expression of type+--+-- RuleData -> Value+prettyExpressionInEnv+  :: Qualifier+  -> Map RuleName T.Name+  -- ^ All expressions+  -> Rule t+  -> T.ExpQ+prettyExpressionInEnv qual lkp (Rule name _ ty) = case ty of+  Terminal _ -> do+    x <- T.newName "x"+    [| \ $(T.conP (quald qual name) [T.varP x])+          -> Pretty.prettyVal $(T.varE x) |]+  NonTerminal sq -> prettyBranches qual lkp sq+  Wrap (Rule inner _ _) -> do+    x <- T.newName "x"+    fVal <- lookupRule lkp inner+    [| \ $(T.conP (quald qual name) [T.varP x])+         -> $(T.varE fVal) $(T.varE x) |]+  Record rules -> do+    (pat, expn) <- prettyConstructor qual lkp name rules+    [| \ $pat -> $expn |]+  Opt (Rule inner _ _) -> do+    x <- T.newName "x"+    fVal <- lookupRule lkp inner+    [| \ $(T.conP (quald qual name) [T.varP x]) ->+      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]) ->+       prettySeq $(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]) ->+       prettyNonEmptySeq $(T.varE fVal) $(T.varE x) |]++prettyBranches+  :: Qualifier+  -> Map RuleName T.Name+  -> NonEmptySeq (Branch t)+  -> T.ExpQ+prettyBranches qual lkp branches = do+  x <- T.newName "x"+  T.lam1E (T.varP x) . T.caseE (T.varE x)+    . fmap (prettyBranch qual lkp) . toList $ branches++lookupRule+  :: Map RuleName T.Name+  -> RuleName+  -> T.Q T.Name+lookupRule mp name = case Map.lookup name mp of+  Nothing -> fail $ "rule lookup failed: " ++ name+  Just n -> return n++-- | Creates a 'T.MatchQ' when given a value constructor name and+-- functions that work on the field values.+deconstruct+  :: T.Name+  -- ^ Name of the constructor+  -> Int+  -- ^ Create this many fields+  -> ([T.ExpQ] -> T.ExpQ)+  -- ^ Each expression that results from each field+  -- is passed to this function.+  -> T.Q (T.PatQ, T.ExpQ)+deconstruct ctorName numFields getFinal = do+  names <- replicateM numFields (T.newName "x")+  let pat = T.conP ctorName . map T.varP $ names+  let body = getFinal . map T.varE $ names+  return (pat, body)++prettyBranch+  :: Qualifier+  -> Map RuleName T.Name+  -> Branch t+  -> T.MatchQ+prettyBranch qual lkp (Branch branchName branches)+  = prettyConstructor qual lkp branchName branches >>= getMatch+  where+    getMatch (pat, expn) = T.match pat (T.normalB expn) []++prettyConstructor+  :: Qualifier+  -> Map RuleName T.Name+  -> String+  -- ^ Name of branch, or name of data constructor+  -> Seq (Rule t)+  -> T.Q (T.PatQ, T.ExpQ)+prettyConstructor qual lkp branchName branches+  = deconstruct (quald qual branchName) (length fieldNames)+      getFinal+  where+    fieldNames = toList . fmap _ruleName $ branches+    getFinal fields = [| Pretty.Con branchName $(values) |]+      where+        values = T.listE $ zipWith getField fields fieldNames+          where+            getField field fieldName = do+              rule <- lookupRule lkp fieldName+              [| $(T.varE rule) $(field) |]

@@ -3,6 +3,7 @@  import Data.Foldable (toList) import Data.Sequence (Seq)+import Data.Sequence.NonEmpty (NonEmptySeq) import qualified Control.Lens as Lens import qualified Language.Haskell.TH as T import qualified Language.Haskell.TH.Syntax as Syntax@@ -64,7 +65,7 @@   -> T.Q [T.Dec] ruleToOptics qual termName (Rule nm _ ty) = case ty of   Terminal ivls -> terminalToOptics qual termName nm ivls-  NonTerminal b1 bs -> sequence $ nonTerminalToOptics qual nm b1 bs+  NonTerminal bs -> sequence $ nonTerminalToOptics qual nm bs   Record sq -> sequence $ recordsToOptics qual nm sq   _ -> return []   @@ -114,11 +115,9 @@   -- optics   -> String   -- ^ Rule name-  -> Branch t-  -> Seq (Branch t)+  -> NonEmptySeq (Branch t)   -> [T.Q T.Dec]-nonTerminalToOptics qual nm b1 bsSeq-  = concat $ makePrism b1 : fmap makePrism bs+nonTerminalToOptics qual nm bsSeq = concat $ fmap makePrism bs   where     bs = toList bsSeq     makePrism (Branch inner rulesSeq) = [ signature, binding ]

@@ -4,10 +4,10 @@ import Data.Foldable (toList) import Data.Maybe (catMaybes) import Data.Sequence (Seq)+import Data.Sequence.NonEmpty (NonEmptySeq) import qualified Control.Lens as Lens import qualified Language.Haskell.TH as T -import Pinchot.NonEmpty import Pinchot.Rules import Pinchot.Types @@ -142,7 +142,7 @@   -> T.Q T.Dec wrappedPlus wrappedName = makeWrapped tupName   where-    tupName = T.conT ''NonEmpty+    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")))

@@ -4,14 +4,14 @@  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.Map (Map) import qualified Data.Map as Map import qualified Language.Haskell.TH as T -import Pinchot.NonEmpty (NonEmpty(NonEmpty))-import qualified Pinchot.NonEmpty as NonEmpty import Pinchot.Types import Pinchot.Rules @@ -84,7 +84,7 @@           . T.forallT [T.PlainTV (T.mkName "t")                       , T.PlainTV (T.mkName "a")] (return [])           $ [t| $(T.conT (quald qual nm)) $(charType) $(anyType)-            -> NonEmpty ($(charType), $(anyType)) |]+            -> NonEmptySeq ($(charType), $(anyType)) |]       | otherwise = T.sigD (T.mkName declName)           . T.forallT [ T.PlainTV (T.mkName "t")                       , T.PlainTV (T.mkName "a")] (return [])@@ -171,16 +171,15 @@     let pat = T.conP (quald qual nm) [T.varP x]     [| \ $(pat) -> NonEmpty.singleton $(T.varE x) |] -  NonTerminal b1 bs -> do+  NonTerminal bs -> do     x <- T.newName "x"     let fTzn | atLeastOne rule = terminalizeProductAtLeastOne              | otherwise = terminalizeProductAllowsZero         tzr (Branch name sq)           = fmap (\(pat, expn) -> T.match pat (T.normalB expn) [])           (fTzn qual lkp name sq)-    m1 <- tzr b1     ms <- traverse tzr . toList $ bs-    T.lamE [T.varP x] (T.caseE (T.varE x) (m1 : ms))+    T.lamE [T.varP x] (T.caseE (T.varE x) ms)    Wrap (Rule inner _ _) -> do     x <- T.newName "x"@@ -200,13 +199,13 @@     [| \ $(pat) -> maybe Seq.empty           $(convert (T.varE (lookupName lkp inner))) $(T.varE x) |]     where-      convert expn | atLeastOne r = [| NonEmpty.flatten . $(expn) |]+      convert expn | atLeastOne r = [| NonEmpty.nonEmptySeqToSeq . $(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.flatten . $(e) |]+        convert e | atLeastOne r = [| NonEmpty.nonEmptySeqToSeq . $(e) |]                   | otherwise = e     [| \ $(pat) -> join . fmap $(convert (T.varE (lookupName lkp inner)))           $ $(T.varE x) |]@@ -217,15 +216,16 @@         let pat = T.conP (quald qual nm) [T.varP x]         [| \ $(pat) ->             let getTermNonEmpty = $(T.varE (lookupName lkp inner))-                getTerms (NonEmpty e1 es) = join . fmap getTermNonEmpty-                  $ NonEmpty.NonEmpty e1 es+                getTerms (NonEmpty.NonEmptySeq e1 es)+                  = join . fmap getTermNonEmpty+                  $ NonEmpty.NonEmptySeq e1 es            in getTerms $(T.varE x)           |]      | otherwise -> do         x <- T.newName "x"         [| let getTermSeq = $(T.varE (lookupName lkp inner))-               getTerms (NonEmpty e1 es) = getTermSeq e1+               getTerms (NonEmpty.NonEmptySeq e1 es) = getTermSeq e1                 `mappend` (join (fmap getTermSeq es))            in getTerms $(T.varE x)           |]@@ -247,7 +247,7 @@             f acc trip = [| $(acc) `mappend` $(procTrip trip) |]             start = procTrip x             procTrip (rule, (_, expn))-              | atLeastOne rule = [| NonEmpty.flatten $(expn) |]+              | atLeastOne rule = [| NonEmpty.nonEmptySeqToSeq $(expn) |]               | otherwise = expn   return (pat, body) @@ -279,7 +279,7 @@             where               f acc (rule, (_, expn))                 | atLeastOne rule =-                    [| $(acc) `mappend` NonEmpty.flatten $(expn) |]+                    [| $(acc) `mappend` NonEmpty.nonEmptySeqToSeq $(expn) |]                 | otherwise =                     [| $(acc) `mappend` $(expn) |]   return (pat, body)@@ -302,7 +302,7 @@   -- symbol. atLeastOne (Rule _ _ ty) = case ty of   Terminal _ -> True-  NonTerminal b1 bs -> branchAtLeastOne b1 && all branchAtLeastOne bs+  NonTerminal bs -> all branchAtLeastOne bs     where       branchAtLeastOne (Branch _ rs) = any atLeastOne rs   Wrap r -> atLeastOne r

@@ -1,14 +1,22 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-} module Pinchot.Types where  import Pinchot.Intervals  import qualified Control.Lens as Lens import Data.Data (Data)+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 +import Pinchot.Pretty+ -- | Type synonym for the name of a production rule.  This will be the -- name of the type constructor for the corresponding type that will -- be created, so this must be a valid Haskell type constructor name.@@ -42,7 +50,7 @@   { _ruleName :: RuleName   , _ruleDescription :: Maybe String   , _ruleType :: RuleType t-  } deriving (Eq, Ord, Show, Data)+  } deriving (Eq, Ord, Show, Data, Generic, PrettyVal)  -- Can't use Template Haskell in this module due to corecursive -- types@@ -75,10 +83,16 @@ 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)+    ]+ -- | The type of a particular rule. data RuleType t   = Terminal (Intervals t)-  | NonTerminal (Branch t) (Seq (Branch t))+  | NonTerminal (NonEmptySeq (Branch t))   | Wrap (Rule t)   | Record (Seq (Rule t))   | Opt (Rule t)@@ -90,9 +104,9 @@ _Terminal = Lens.prism' (\i -> Terminal i)   (\r -> case r of { Terminal i -> Just i; _ -> Nothing }) -_NonTerminal :: Lens.Prism' (RuleType t) (Branch t, Seq (Branch t))-_NonTerminal = Lens.prism' (\(b, bs) -> NonTerminal b bs)-  (\r -> case r of { NonTerminal b bs -> Just (b, bs); _ -> Nothing })+_NonTerminal :: Lens.Prism' (RuleType t) (NonEmptySeq (Branch t))+_NonTerminal = Lens.prism' (\b -> NonTerminal b)+  (\r -> case r of { NonTerminal b -> Just b; _ -> Nothing })  _Wrap :: Lens.Prism' (RuleType t) (Rule t) _Wrap = Lens.prism' (\r -> Wrap r)@@ -114,6 +128,17 @@ _Plus = Lens.prism' (\r -> Plus r)   (\r -> case r of { Plus x -> Just x; _ -> 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]+ -- | The name of a field in a record, without the leading -- underscore. recordFieldName@@ -170,7 +195,7 @@   { _line :: Int   , _col :: Int   , _pos :: Int-  } deriving (Eq, Ord, Read, Show, Data)+  } deriving (Eq, Ord, Read, Show, Data, Generic, PrettyVal)  line :: Lens.Lens' Loc Int line = Lens.lens _line (\r l -> r { _line = l })

@@ -1,18 +0,0 @@--- | A compatibility shim so Pinchot can work with versions of the--- template-haskell library both before and after version 2.11.--- The .cabal file is set up so this version of this module is used--- for 2.11 and newer versions of template-haskell.--module Pinchot.Internal.TemplateHaskellShim where--import qualified Language.Haskell.TH as T--newtypeD-  :: T.CxtQ -> T.Name -> [T.TyVarBndr] -> T.ConQ -> [T.Name] -> T.DecQ-newtypeD cxt name tyVars ctor derives-  = T.newtypeD cxt name tyVars Nothing ctor (return $ fmap T.ConT derives)--dataD-  :: T.CxtQ -> T.Name -> [T.TyVarBndr] -> [T.ConQ] -> [T.Name] -> T.DecQ-dataD cxt name tyVars ctors derives-  = T.dataD cxt name tyVars Nothing ctors (return $ fmap T.ConT derives)

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

@@ -2,17 +2,17 @@ -- Cartel is available at: -- http://www.github.com/massysett/cartel ----- Script name used to generate: genCabal.hs--- Generated on: 2016-07-07 14:15:57.679603 EDT+-- Script name used to generate: gen-pinchot-cabal+-- Generated on: 2016-08-06 20:09:06.412446 EDT -- Cartel library version: 0.16.0.0  name: pinchot-version: 0.18.2.0-cabal-version: >= 1.14+version: 0.20.0.0+cabal-version: >= 1.10 license: BSD3 license-file: LICENSE build-type: Simple-copyright: 2015-2016 Omari Norman+copyright: Copyright (c) 2015 - 2016 Omari Norman author: Omari Norman maintainer: omari@smileystation.com stability: Experimental@@ -20,19 +20,23 @@ bug-reports: http://www.github.com/massysett/pinchot/issues synopsis: Write grammars, not parsers description:-  Pinchot provides a simple language that you use to write a Haskell-  value that describes a context-free grammar.  Using this value, you can-  automatically generate data types corresponding to the grammar,-  as well as an Earley parser to parse strings in that grammar.-  .-  For more documentation, see the Haddocks for the main Pinchot module.+  Please see README.md category: Development extra-source-files:-  "newTemplateHaskell/Pinchot/Internal/TemplateHaskellShim.hs"-  "oldTemplateHaskell/Pinchot/Internal/TemplateHaskellShim.hs"-  README+  README.md  Library+  build-depends:+      base >= 4.9 && < 5+    , containers >= 0.5.6.2+    , transformers >= 0.4.2.0+    , template-haskell >= 2.11+    , 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@@ -46,7 +50,7 @@     Pinchot.Examples.Terminalize     Pinchot.Intervals     Pinchot.Locator-    Pinchot.NonEmpty+    Pinchot.Pretty     Pinchot.RecursiveDo     Pinchot.Rules     Pinchot.SyntaxTree@@ -55,40 +59,36 @@     Pinchot.SyntaxTree.Wrappers     Pinchot.Terminalize     Pinchot.Types-  build-depends:-      base >= 4.8.0.0 && < 5-    , containers >= 0.5.6.2-    , transformers >= 0.4.2.0-    , Earley >= 0.11.0.1-    , lens >= 4.13-    , ListLike >= 4.2.1-    , semigroups >= 0.18.1-  if flag(oldTemplateHaskell)-    build-depends:-        template-haskell >= 2.10 && < 2.11-    hs-source-dirs:-      oldTemplateHaskell-  else-    build-depends:-        template-haskell >= 2.11-    hs-source-dirs:-      newTemplateHaskell-  other-modules:-    Pinchot.Internal.TemplateHaskellShim-  other-extensions:-    TemplateHaskell+  ghc-options:+    -W   default-language: Haskell2010   hs-source-dirs:     lib+  other-extensions:+    TemplateHaskell  source-repository head   type: git-  location: https://github.com/massysett/penny.git+  location: https://github.com/massysett/pinchot.git  Executable newman-  main-is: newman.hs-  if flag(executables)+  if !(flag(executables))+    buildable: False+  else     buildable: True+    hs-source-dirs:+      exe+    build-depends:+        base >= 4.9 && < 5+      , containers >= 0.5.6.2+      , transformers >= 0.4.2.0+      , template-haskell >= 2.11+      , 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@@ -102,7 +102,7 @@       Pinchot.Examples.Terminalize       Pinchot.Intervals       Pinchot.Locator-      Pinchot.NonEmpty+      Pinchot.Pretty       Pinchot.RecursiveDo       Pinchot.Rules       Pinchot.SyntaxTree@@ -111,40 +111,63 @@       Pinchot.SyntaxTree.Wrappers       Pinchot.Terminalize       Pinchot.Types+    ghc-options:+      -W+    default-language: Haskell2010     hs-source-dirs:+      lib+    other-extensions:+      TemplateHaskell+  main-is: newman.hs++Executable newmanPretty+  if !(flag(executables))+    buildable: False+  else+    buildable: True+    hs-source-dirs:       exe     build-depends:-        base >= 4.8.0.0 && < 5+        base >= 4.9 && < 5       , containers >= 0.5.6.2       , transformers >= 0.4.2.0+      , template-haskell >= 2.11       , Earley >= 0.11.0.1+      , pretty-show >= 1.6.9       , lens >= 4.13       , ListLike >= 4.2.1       , semigroups >= 0.18.1-    if flag(oldTemplateHaskell)-      build-depends:-          template-haskell >= 2.10 && < 2.11-      hs-source-dirs:-        oldTemplateHaskell-    else-      build-depends:-          template-haskell >= 2.11-      hs-source-dirs:-        newTemplateHaskell+      , non-empty-sequence >= 0.2     other-modules:-      Pinchot.Internal.TemplateHaskellShim-    other-extensions:-      TemplateHaskell+      Pinchot+      Pinchot.Earley+      Pinchot.Examples+      Pinchot.Examples.AllRulesRecord+      Pinchot.Examples.Earley+      Pinchot.Examples.Newman+      Pinchot.Examples.Postal+      Pinchot.Examples.RulesToOptics+      Pinchot.Examples.SyntaxTrees+      Pinchot.Examples.Terminalize+      Pinchot.Intervals+      Pinchot.Locator+      Pinchot.Pretty+      Pinchot.RecursiveDo+      Pinchot.Rules+      Pinchot.SyntaxTree+      Pinchot.SyntaxTree.Instancer+      Pinchot.SyntaxTree.Optics+      Pinchot.SyntaxTree.Wrappers+      Pinchot.Terminalize+      Pinchot.Types+    ghc-options:+      -W     default-language: Haskell2010     hs-source-dirs:       lib-  else-    buildable: False--Flag oldTemplateHaskell-  description: Use version of Template Haskell before 2.11-  default: False-  manual: False+    other-extensions:+      TemplateHaskell+  main-is: newmanPretty.hs  Flag executables   description: Build executables