packages feed

typed-peg (empty) → 0.1.0.0

raw patch · 18 files changed

+2367/−0 lines, 18 filesdep +basedep +template-haskelldep +typed-peg

Dependencies added: base, template-haskell, typed-peg

Files

+ CHANGELOG.md view
@@ -0,0 +1,14 @@+# Changelog++## 0.1.0.0 — 2026-08-28++### Added++- Initial release.+- Type-safe PEG parser combinators with compile-time left-recursion detection+  via type families (`PEG.Grammar`).+- FIRST-set and nullability information tracked at the type level (`PEG.Type`,+  `PEG.TyLevel`).+- Indentation-sensitive parsing primitives (`PEG.Indent`).+- Quasi-quoter `pegRules` for writing grammars in a concrete DSL (`PEG.QQ`).+- Simple semantics interpreter (`PEG.Semantics.Simple`).
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2026, Rodrigo Ribeiro++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Rodrigo Ribeiro nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,39 @@+# typed-peg++Type-safe PEG (Parsing Expression Grammar) parser combinators for Haskell.++Grammar non-terminals are indexed at the type level by their nullability and+FIRST sets, so left-recursive grammars are caught at compile time rather than+looping at runtime.++## Features++- Type-level FIRST-set and nullability tracking+- Compile-time left-recursion detection (type error)+- Indentation-sensitive parsing (`PEG.Indent`)+- Quasi-quoter for concrete grammar syntax (`PEG.QQ`)++## Quick start++```haskell+import PEG++-- Define a grammar using the quasi-quoter+-- See examples/Arith.hs for a complete arithmetic expression parser+```++## Building++```bash+cabal build+```++## Examples++```bash+cabal test typed-peg-examples+```++## License++BSD-3-Clause. See [LICENSE](LICENSE).
+ examples/Arith.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++module Arith+  ( Exp (..)+  , evalExp+  , showExp+  , ArithEnv+  , arith+  ) where++import PEG+import PEG.QQ (pegRules)++data Exp+  = Lit Int+  | Neg Exp+  | Add Exp Exp+  | Sub Exp Exp+  | Mul Exp Exp+  | Div Exp Exp+  deriving (Eq, Show)++evalExp :: Exp -> Int+evalExp (Lit n)   = n+evalExp (Neg e)   = negate (evalExp e)+evalExp (Add a b) = evalExp a + evalExp b+evalExp (Sub a b) = evalExp a - evalExp b+evalExp (Mul a b) = evalExp a * evalExp b+evalExp (Div a b) = evalExp a `div` evalExp b++showExp :: Exp -> String+showExp (Lit n)   = show n+showExp (Neg e)   = "(-" ++ showExp e ++ ")"+showExp (Add a b) = bin "+" a b+showExp (Sub a b) = bin "-" a b+showExp (Mul a b) = bin "*" a b+showExp (Div a b) = bin "/" a b++bin :: String -> Exp -> Exp -> String+bin op a b = "(" ++ showExp a ++ " " ++ op ++ " " ++ showExp b ++ ")"++addOp :: Exp -> (Char, Exp) -> Exp+addOp l ('+', r) = Add l r+addOp l ('-', r) = Sub l r+addOp l ('*', r) = Mul l r+addOp l ('/', r) = Div l r+addOp _ (c  , _) = error ("addOp: unexpected operator " ++ show c)++type ArithEnv =+  '[ '("expr"  , 'EnvEntry ('MkTy 'False '["term", "factor", "number"]) Exp)+   , '("term"  , 'EnvEntry ('MkTy 'False '["factor", "number"])         Exp)+   , '("factor", 'EnvEntry ('MkTy 'False '["number"])                   Exp)+   , '("number", 'EnvEntry ('MkTy 'False '[])                           Exp)+   ]++arith :: Grammar ArithEnv _ Exp+arith =+  Grammar+    [pegRules|+       expr   <- t:term ts:(o:[+-] u:term)* { foldl addOp t ts }+       term   <- f:factor fs:(o:[*/] g:factor)*+                   { foldl (\acc (op, r) -> addOp acc (op, r)) f fs }+       factor <- n:number+               / '(' e:expr ')'+               / '-' f:factor { Neg f }+       number <- ds:[0-9]+ { Lit (read ds :: Int) }+    |]+    (nt @"expr")
+ examples/Layout.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++module Layout+  ( DoStmt (..)+  , DoEnv+  , doExp+  , layoutOpts+  ) where++import PEG+import PEG.QQ (pegExpr, pegRules)++data DoStmt+  = Atom   String+  | Nested [DoStmt]+  deriving (Eq, Show)++type DoEnv =+  '[ '("doexp" , 'EnvEntry ('MkTy 'False '[])                               [DoStmt])+   , '("istmts", 'EnvEntry ('MkTy 'False '["ws", "stmt", "doexp", "name"]) [DoStmt])+   , '("stmts" , 'EnvEntry ('MkTy 'False '["ws"])                          [DoStmt])+   , '("stmt"  , 'EnvEntry ('MkTy 'False '["doexp", "name"])               DoStmt)+   , '("name"  , 'EnvEntry ('MkTy 'False '[])                              String)+   , '("ws"    , 'EnvEntry ('MkTy 'True  '[])                              ())+   ]++doExp :: Grammar DoEnv _ [DoStmt]+doExp =+  Grammar+    [pegRules|+       doexp  <- "do" b:(i:istmts / j:stmts)++       istmts <- ss:(ws st:|s:stmt|)+^>++       stmts  <- r:(ws '{' ws s:stmt ss:(ws ';' ws t:stmt)* ws '}' { s : ss })^~++       stmt   <- d:doexp { Nested d } / n:name { Atom n }++       name   <- cs:[a-z]+++       ws     <- [ \t\r\n]*_~+    |]+    [pegExpr| ws d:doexp ws !. |]++layoutOpts :: Opts+layoutOpts = defaultOpts { optTokenMode = relD geR }
+ examples/Main.hs view
@@ -0,0 +1,25 @@+module Main where++import PEG (parse, parseWith, Result(..))+import Arith (arith, evalExp)+import Layout (doExp, layoutOpts)++showResult :: Show a => Result a -> String+showResult (OK a _ _) = "OK " ++ show a+showResult Fail        = "Fail"++main :: IO ()+main = do+  putStrLn "=== Arith ==="+  let testArith s =+        let r = case parse arith s of+                  OK e _ _ -> "OK " ++ show (evalExp e)+                  Fail      -> "Fail"+        in putStrLn $ s ++ " => " ++ r+  testArith "1+2*3"+  testArith "(1+2)*3"+  testArith "42"++  putStrLn "\n=== Layout (do-notation) ==="+  let testLayout s = putStrLn $ showResult (parseWith layoutOpts doExp s)+  testLayout "foo\n  bar\n  baz\nqux"
+ src/PEG.hs view
@@ -0,0 +1,37 @@+-- | Type-safe PEG (Parsing Expression Grammar) parser combinators.+--+-- Grammar non-terminals are indexed at the type level by their nullability and+-- FIRST sets. Left-recursive grammars are rejected at compile time via a+-- 'GHC.TypeLits.TypeError'.+--+-- == Quick start+--+-- @+-- import PEG+-- import PEG.QQ (pegRules)+-- @+--+-- 1. Declare the grammar environment as a type-level list of @(name, entry)@+--    pairs (see 'PEG.Type.Env').+-- 2. Build a 'Grammar' using 'pegRules' (quasi-quoter) or the combinators in+--    "PEG.Syntax".+-- 3. Run the grammar on a 'String' with 'parse' or 'parseWith'.+--+-- See the @examples/@ directory for complete working grammars.+module PEG+  ( module PEG.Type+  , module PEG.TyLevel+  , module PEG.Member+  , module PEG.Indent+  , module PEG.Syntax+  , module PEG.Grammar+  , module PEG.Parse+  ) where++import PEG.Grammar+import PEG.Indent+import PEG.Member+import PEG.Parse+import PEG.Syntax+import PEG.TyLevel+import PEG.Type
+ src/PEG/Grammar.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE KindSignatures       #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Grammar type and the acyclicity constraint.+--+-- A 'Grammar' bundles a set of named rules ('Rules') and a start expression.+-- The 'Acyclic' constraint is checked at the definition site of every+-- 'Grammar' value: if any non-terminal is left-recursive (its own name appears+-- in its own FIRST set), GHC emits a 'GHC.TypeLits.TypeError' naming the+-- offending non-terminal.+module PEG.Grammar+  ( Rules (..)+  , Grammar (..)+  , Acyclic+  ) where++import Data.Kind    (Constraint, Type)+import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError)++import PEG.Syntax  (Name, PExp)+import PEG.TyLevel (Elem)+import PEG.Type++-- | A typed, heterogeneous list of named grammar rules.+--+-- @'Rules' env defs@ is a list of rules whose bodies reference non-terminals+-- in @env@ and whose definitions together form @defs@.+data Rules (env :: Env) (defs :: Env) where+  RNil  :: Rules env '[]+  RCons :: Name s+        -> PExp env ty a+        -> Rules env rest+        -> Rules env ('(s, 'EnvEntry ty a) ': rest)++type family Acyclic (env :: Env) :: Constraint where+  Acyclic '[]                             = ()+  Acyclic ('(s, 'EnvEntry ty _) ': rest) =+    (NotLeftRec s (Elem s (First ty)) ty, Acyclic rest)++type family NotLeftRec (s :: Symbol) (b :: Bool) (ty :: Ty) :: Constraint where+  NotLeftRec _ 'False _  = ()+  NotLeftRec s 'True  ty =+    TypeError ('Text "Left-recursive non-terminal: " ':<>: 'ShowType s+         ':$$: 'Text "Its head set already contains itself: "+               ':<>: 'ShowType (First ty)+         ':$$: 'Text "Violates the acyclicity condition i `notElem` Gamma(i).F.")++-- | A complete PEG grammar: a set of mutually recursive rules and a start+-- expression.+--+-- Constructing a 'Grammar' value discharges the 'Acyclic' constraint, so+-- any left-recursion in @env@ becomes a compile-time type error.+data Grammar (env :: Env) (startTy :: Ty) (startA :: Type) where+  Grammar :: Acyclic env+          => Rules env env+          -> PExp env startTy startA+          -> Grammar env startTy startA
+ src/PEG/Indent.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE KindSignatures #-}++-- | Indentation-sensitive parsing via column intervals and relations.+--+-- This module implements the algebraic model of indentation from+-- /Layout-sensitive grammars and combinators/ (Adams, 2013).+-- Columns are represented as integer positions; valid columns are maintained+-- as an 'Interval'.  Each parser step filters the interval through a 'RelD'+-- (a monotone column relation), allowing constructs such as \"must be+-- indented more than the enclosing block\".+--+-- == Predefined relations+--+-- * 'eqR'    — same column (align with enclosing block)+-- * 'geR'    — greater-or-equal column (standard indented block)+-- * 'gtR'    — strictly greater column+-- * 'anyR'   — any column (no constraint)+-- * 'gapR'   — indented by a fixed offset+-- * 'constR' — fixed column+-- * 'offsetR'— shifted by @k@ columns+module PEG.Indent+  ( Bound (..)+  , Interval (..)+  , emptyI+  , fullI+  , singletonI+  , nullI+  , memberI+  , interI+  , RelD (..)+  , Rel (..)+  , relName+  , image+  , preimage+  , eqR+  , gtR+  , geR+  , anyR+  , gapR+  , constR+  , offsetR+  ) where++import GHC.TypeLits (Symbol)++data Bound = Fin !Int | Inf+  deriving (Eq, Show)++instance Ord Bound where+  compare Inf     Inf     = EQ+  compare Inf     (Fin _) = GT+  compare (Fin _) Inf     = LT+  compare (Fin a) (Fin b) = compare a b++data Interval = Interval { ivLo :: !Int, ivHi :: !Bound }+  deriving (Eq, Show)++emptyI :: Interval+emptyI = Interval 1 (Fin 0)++fullI :: Interval+fullI = Interval 0 Inf++singletonI :: Int -> Interval+singletonI i = Interval i (Fin i)++nullI :: Interval -> Bool+nullI (Interval lo hi) = Fin lo > hi++memberI :: Int -> Interval -> Bool+memberI i (Interval lo hi) = i >= lo && Fin i <= hi++interI :: Interval -> Interval -> Interval+interI (Interval l1 h1) (Interval l2 h2) = Interval (max l1 l2) (min h1 h2)++data RelD = RelD+  { rdName      :: String+  , rdDom       :: Interval+  , rdLo        :: Int -> Int+  , rdHi        :: Int -> Bound+  , rdInvLo     :: Int -> Int+  , rdInvHi     :: Int -> Bound+  , rdModeLo    :: Bound+  , rdModeHi    :: Bound+  , rdModeInvLo :: Bound+  , rdModeInvHi :: Bound+  }++newtype Rel (n :: Symbol) = Rel { relD :: RelD }++relName :: Rel n -> String+relName = rdName . relD++instance Show (Rel n) where+  show = relName++clampMode :: Bound -> Interval -> Maybe Int+clampMode (Fin m) (Interval lo hi) = Just $ case hi of+  Inf   -> max lo m+  Fin h -> max lo (min m h)+clampMode Inf     (Interval lo hi) = case hi of+  Inf   -> Nothing+  Fin h -> Just (max lo h)++supOver :: Bound -> (Int -> Bound) -> Interval -> Bound+supOver mode f iv = maybe Inf f (clampMode mode iv)++infOver :: Bound -> (Int -> Int) -> Interval -> Int+infOver mode f iv = maybe 0 f (clampMode mode iv)++image :: RelD -> Interval -> Interval+image rd i0+  | nullI i   = emptyI+  | otherwise = Interval (infOver (rdModeLo rd) (rdLo rd) i)+                         (supOver (rdModeHi rd) (rdHi rd) i)+  where+    i = interI i0 (rdDom rd)++preimage :: RelD -> Interval -> Interval+preimage rd i+  | nullI i   = emptyI+  | otherwise = Interval (infOver (rdModeInvLo rd) (rdInvLo rd) i)+                         (supOver (rdModeInvHi rd) (rdInvHi rd) i)++eqR :: Rel "="+eqR = Rel RelD+  { rdName      = "="+  , rdDom       = fullI+  , rdLo        = id+  , rdHi        = Fin+  , rdInvLo     = id+  , rdInvHi     = Fin+  , rdModeLo    = Fin 0+  , rdModeHi    = Inf+  , rdModeInvLo = Fin 0+  , rdModeInvHi = Inf+  }++gapR :: Int -> Rel "gap"+gapR = Rel . gapD "gap"++gapD :: String -> Int -> RelD+gapD name k = RelD+  { rdName      = name+  , rdDom       = Interval k Inf+  , rdLo        = const 0+  , rdHi        = \i -> Fin (i - k)+  , rdInvLo     = \i -> i + k+  , rdInvHi     = const Inf+  , rdModeLo    = Fin 0+  , rdModeHi    = Inf+  , rdModeInvLo = Fin 0+  , rdModeInvHi = Fin 0+  }++gtR :: Rel ">"+gtR = Rel (gapD ">" 1)++geR :: Rel ">="+geR = Rel (gapD ">=" 0)++anyR :: Rel "~"+anyR = Rel RelD+  { rdName      = "~"+  , rdDom       = fullI+  , rdLo        = const 0+  , rdHi        = const Inf+  , rdInvLo     = const 0+  , rdInvHi     = const Inf+  , rdModeLo    = Fin 0+  , rdModeHi    = Fin 0+  , rdModeInvLo = Fin 0+  , rdModeInvHi = Fin 0+  }++constR :: Int -> Rel "const"+constR c = Rel RelD+  { rdName      = "const " ++ show c+  , rdDom       = singletonI c+  , rdLo        = const 0+  , rdHi        = const Inf+  , rdInvLo     = const c+  , rdInvHi     = const (Fin c)+  , rdModeLo    = Fin 0+  , rdModeHi    = Fin 0+  , rdModeInvLo = Fin 0+  , rdModeInvHi = Fin 0+  }++offsetR :: Int -> Rel "offset"+offsetR k = Rel RelD+  { rdName      = "+" ++ show k+  , rdDom       = Interval k Inf+  , rdLo        = \i -> i - k+  , rdHi        = \i -> Fin (i - k)+  , rdInvLo     = \i -> i + k+  , rdInvHi     = \i -> Fin (i + k)+  , rdModeLo    = Fin 0+  , rdModeHi    = Inf+  , rdModeInvLo = Fin 0+  , rdModeInvHi = Inf+  }
+ src/PEG/Member.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++-- | Membership witnesses for heterogeneous type-level environments.+--+-- 'Member' is a proof that a name @s@ with type @ty@ and result @a@ is+-- present in the environment @env@.  'KnownMember' is the class that allows+-- the proof to be materialised from type information at runtime, enabling+-- non-terminal lookup during parsing.+module PEG.Member+  ( Member (..)+  , KnownMember (..)+  ) where++import Data.Kind    (Type)+import Data.Proxy   (Proxy (..))+import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError)++import PEG.Type+import PEG.TyLevel (SymEq)++data Member (s :: Symbol) (env :: Env) (ty :: Ty) (a :: Type) where+  Here  :: Member s ('(s, 'EnvEntry ty a) ': rest) ty a+  There :: Member s rest ty a -> Member s (e ': rest) ty a++class KnownMember (s :: Symbol) (env :: Env) (ty :: Ty) (a :: Type) where+  member :: Member s env ty a++instance TypeError ('Text "Undefined non-terminal: " ':<>: 'ShowType s+               ':$$: 'Text "The grammar has no rule for this name.")+      => KnownMember s '[] ty a where+  member = error "PEG.Member: unreachable"++instance KnownMember' (SymEq s t) s ('(t, e) ': rest) ty a+      => KnownMember s ('(t, e) ': rest) ty a where+  member = member' (Proxy :: Proxy (SymEq s t))++class KnownMember' (b :: Bool) (s :: Symbol) (env :: Env)+                   (ty :: Ty) (a :: Type) where+  member' :: Proxy b -> Member s env ty a++instance (s ~ t, e ~ 'EnvEntry ty a)+      => KnownMember' 'True s ('(t, e) ': rest) ty a where+  member' _ = Here++instance KnownMember s rest ty a+      => KnownMember' 'False s ('(t, e) ': rest) ty a where+  member' _ = There member
+ src/PEG/Parse.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}++-- | Running a 'Grammar' against a 'String'.+--+-- The top-level entry points are 'parse' (uses 'defaultOpts') and 'parseWith'+-- (accepts custom 'Opts' for indentation-sensitive parsing).  Both return a+-- 'Result' that records the matched value, the consumed prefix, and the+-- remaining suffix.+module PEG.Parse+  ( Result (..)+  , parse+  , parseWith+  , eval+  , Opts (..)+  , defaultOpts+  , Input+  , PState (..)+  , columns+  ) where++import PEG.Grammar+import PEG.Indent+import PEG.Member+import PEG.Syntax+import PEG.Type+import PEG.TyLevel (Lookup)++-- | The result of running a grammar.+--+-- @'OK' a consumed rest@ means the grammar matched, producing value @a@.+-- @consumed@ is the prefix of the input that was consumed; @rest@ is the+-- remaining input.+data Result a+  = OK a String String+  | Fail+  deriving (Show, Eq)++-- | A string annotated with column positions, as produced by 'columns'.+type Input = [(Char, Int)]++-- | Internal parser state.+data PState = PState+  { stInput :: Input     -- ^ Remaining input with column positions.+  , stCands :: !Interval -- ^ Current candidate column interval.+  , stAlign :: !Bool     -- ^ Whether the next token must be aligned.+  }++-- | Annotate every character in a string with its column position.+-- Tab stops are expanded according to @tabWidth@.+columns :: Int -> String -> Input+columns tabWidth = go 0+  where+    go _ []     = []+    go c (x:xs) = (x, c) : go (next c x) xs++    next _ '\n' = 0+    next c '\t'+      | tabWidth > 1 = ((c `div` tabWidth) + 1) * tabWidth+      | otherwise    = c + 1+    next c _    = c + 1++-- | Parser configuration.+data Opts = Opts+  { optTokenMode :: RelD     -- ^ Default column relation between tokens.+  , optCands     :: Interval -- ^ Initial candidate column interval.+  , optTabWidth  :: Int      -- ^ Number of columns per tab stop.+  }++-- | Default options: accept tokens at any column, tab width of 8.+defaultOpts :: Opts+defaultOpts = Opts+  { optTokenMode = relD anyR+  , optCands     = fullI+  , optTabWidth  = 8+  }++-- | Run a grammar with 'defaultOpts'.+parse :: Grammar env ty a -> String -> Result a+parse = parseWith defaultOpts++-- | Run a grammar with custom 'Opts'.+parseWith :: Opts -> Grammar env ty a -> String -> Result a+parseWith opts (Grammar rules start) input =+  case eval rules start (optTokenMode opts) st0 of+    Nothing      -> Fail+    Just (a, st) ->+      let n = length input - length (stInput st)+      in OK a (take n input) (drop n input)+  where+    st0 = PState+      { stInput = columns (optTabWidth opts) input+      , stCands = optCands opts+      , stAlign = False+      }++-- | Low-level evaluator: run a 'PExp' against a 'PState' under a given column+-- relation.  Exposed for advanced use; most callers should use 'parse' or+-- 'parseWith'.+eval :: forall env ty a+      . Rules env env+     -> PExp env ty a+     -> RelD+     -> PState+     -> Maybe (a, PState)+eval rules = go+  where+    go :: forall t b. PExp env t b -> RelD -> PState -> Maybe (b, PState)+    go (Pure x) _ st = Just (x, st)++    go (Term c) tau st = do+      (x, st') <- terminal tau st+      if x == c then Just (c, st') else Nothing++    go AnyChar tau st = terminal tau st++    go (NT (_ :: Name s)) tau st =+      go (ruleFor (member :: Member s env (TyOf (Lookup s env))+                                          (ResOf (Lookup s env)))+                  rules)+         tau st++    go (Seq ef ex) tau st = do+      (f, st')  <- go ef tau st+      (x, st'') <- go ex tau st'+      pure (f x, st'')++    go (Choice e1 e2) tau st = case go e1 tau st of+      Just r  -> Just r+      Nothing -> go e2 tau st++    go (Star e) tau st = Just (starLoop (go e tau) st)++    go (Not e) tau st = case go e tau st of+      Just _  -> Nothing+      Nothing -> Just ((), st)++    go (Map f e) tau st = do+      (x, st') <- go e tau st+      pure (f x, st')++    go (Indent rho e) tau st = do+      (x, st') <- go e tau st { stCands = preimage rd (stCands st) }+      pure ( x+           , st' { stCands = interI (stCands st) (image rd (stCands st')) } )+      where+        rd = relD rho++    go (Position sigma e) _ st = go e (relD sigma) st++    go (Align e) tau st = do+      (x, st') <- go e tau st { stAlign = True }+      pure (x, st' { stAlign = stAlign st && stAlign st' })++terminal :: RelD -> PState -> Maybe (Char, PState)+terminal tau (PState input cands aligned) = case input of+  []            -> Nothing+  ((x, i) : xs)+    | aligned   ->+        if memberI i cands+          then Just (x, PState xs (singletonI i) False)+          else Nothing+    | otherwise ->+        if memberI i (preimage tau cands)+          then Just (x, PState xs (interI cands (image tau (singletonI i))) False)+          else Nothing++starLoop :: (PState -> Maybe (a, PState)) -> PState -> ([a], PState)+starLoop step = loop+  where+    loop st = case step st of+      Nothing       -> ([], st)+      Just (x, st') -> let (xs, rest) = loop st' in (x : xs, rest)++ruleFor :: Member s defs ty a -> Rules env defs -> PExp env ty a+ruleFor Here      (RCons _ body _)    = body+ruleFor (There m) (RCons _ _    rest) = ruleFor m rest
+ src/PEG/QQ.hs view
@@ -0,0 +1,474 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Quasi-quoters for writing PEG grammars in a concrete DSL.+--+-- == Grammar syntax+--+-- @+-- [pegRules|+--   ruleName <- body+--   ...+-- |]+-- @+--+-- Each rule binds named sub-expressions with @name:subexpr@ and applies+-- a Haskell action in braces: @{ haskellExpr }@.+-- Ordered choice is written with @\/@; Kleene star with @*@; plus with @+@;+-- optional with @?@; negation with @!@.+-- Character classes use @[...]@ syntax.+--+-- The 'pegExpr' quasi-quoter produces a single 'PEG.Syntax.PExp' value,+-- while 'pegRules' produces a complete set of named rules (a+-- 'PEG.Grammar.Rules' value) to be passed to 'PEG.Grammar.Grammar'.+module PEG.QQ+  ( pegExpr+  , pegRules+  ) where++import Control.Monad              (foldM)+import Data.List                  (nub)+import Language.Haskell.TH        (Exp (..), Pat (..), Q)+import qualified Language.Haskell.TH      as TH+import Language.Haskell.TH.Quote  (QuasiQuoter (..))++import PEG+import PEG.QQ.HsExp (parseHsExp)++data Def = Def String PExpr+  deriving Show++data Item = Item (Maybe String) PExpr+  deriving Show++data PExpr+  = EChoice  [PExpr]+  | ESeq     [Item] (Maybe String)+  | EAnd     PExpr+  | ENot     PExpr+  | EOpt     PExpr+  | EStar    PExpr+  | EPlus    PExpr+  | EChar    Char+  | EString  String+  | EClass   [(Char,Char)]+  | EDot+  | ENT      String+  | EIndent  RelS PExpr+  | EPos     RelS PExpr+  | EAlign   PExpr+  deriving Show++data RelS+  = RGt+  | RGe+  | REq+  | RAny+  | ROffset Int+  | RNamed  String+  deriving Show++type P a = String -> Either String (a, String)++errorAt :: String -> String -> Either String a+errorAt msg s = Left $ msg ++ " at: " ++ show (take 30 s)++spaces :: String -> String+spaces []         = []+spaces ('#':xs)   = spaces (drop 1 (dropWhile (/= '\n') xs))+spaces (c:xs)+  | c == ' ' || c == '\t' || c == '\n' || c == '\r' = spaces xs+  | otherwise = c:xs++tok :: String -> P ()+tok t s = case stripPrefix t (spaces s) of+  Just r  -> Right ((), r)+  Nothing -> errorAt ("expected " ++ show t) s+  where+    stripPrefix [] xs                 = Just xs+    stripPrefix (p:ps) (x:xs) | p==x  = stripPrefix ps xs+    stripPrefix _ _                   = Nothing++ident :: P String+ident s0 = case spaces s0 of+  (c:xs) | isIdStart c ->+    let (rest, leftover) = span isIdCont xs+    in Right (c:rest, leftover)+  s -> errorAt "expected identifier" s+  where+    isIdStart c = c == '_' || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')+    isIdCont c  = isIdStart c || (c >= '0' && c <= '9')++charLit :: P Char+charLit s0 = case spaces s0 of+  ('\'':xs) -> do (c, r1) <- escChar '\'' xs+                  case r1 of+                    ('\'':r2) -> Right (c, r2)+                    _         -> errorAt "expected closing '" r1+  s         -> errorAt "expected character literal" s++strLit :: P String+strLit s0 = case spaces s0 of+  ('"':xs) -> loop xs+  s        -> errorAt "expected string literal" s+  where+    loop ('"':r) = Right ("", r)+    loop r0      = do (c, r1) <- escChar '"' r0+                      (cs, r2) <- loop r1+                      pure (c:cs, r2)++escChar :: Char -> P Char+escChar _ ('\\':e:xs) = case e of+  'n'  -> Right ('\n', xs)+  't'  -> Right ('\t', xs)+  'r'  -> Right ('\r', xs)+  '\\' -> Right ('\\', xs)+  '\'' -> Right ('\'', xs)+  '"'  -> Right ('"',  xs)+  '['  -> Right ('[',  xs)+  ']'  -> Right (']',  xs)+  '0'  -> Right ('\0', xs)+  _    -> errorAt ("unknown escape \\" ++ [e]) xs+escChar stopC (c:xs)+  | c == stopC = errorAt "unexpected close quote" (c:xs)+  | otherwise  = Right (c, xs)+escChar _ [] = Left "unexpected end of input in literal"++classLit :: P [(Char, Char)]+classLit s0 = case spaces s0 of+  ('[':xs) -> loop xs+  s        -> errorAt "expected character class" s+  where+    loop (']':r) = Right ([], r)+    loop []      = Left "unterminated character class"+    loop r0      = do+      (c1, r1) <- escChar ']' r0+      case r1 of+        ('-':']':r2) -> pure ([(c1, c1), ('-', '-')], r2)+        ('-':r2) ->+          do (c2, r3) <- escChar ']' r2+             (rs, r4) <- loop r3+             pure ((c1, c2) : rs, r4)+        _ ->+          do (rs, r2) <- loop r1+             pure ((c1, c1) : rs, r2)++actionLit :: P String+actionLit s0 = case spaces s0 of+  ('{':xs) -> go (1 :: Int) ' ' [] xs+  s        -> errorAt "expected a semantic action" s+  where+    go _ _ _ [] = Left "unterminated semantic action: missing '}'"+    go n prev acc s = case s of+      ('{':'-':r) -> do+        (com, r') <- blockComment (1 :: Int) r+        go n '}' (revApp ("{-" ++ com) acc) r'+      ('"':r) -> do+        (str, r') <- literalBody '"' r+        go n '"' (revApp ('"' : str) acc) r'+      ('\'':r) | not (isIdChar prev) -> do+        (ch, r') <- literalBody '\'' r+        go n '\'' (revApp ('\'' : ch) acc) r'+      ('{':r) -> go (n + 1) '{' ('{' : acc) r+      ('}':r) | n == 1    -> Right (reverse acc, r)+              | otherwise -> go (n - 1) '}' ('}' : acc) r+      (c:_) | c `elem` symChars ->+        let (sym, r) = span (`elem` symChars) s+        in if all (== '-') sym && length sym >= 2+             then let (line, r') = span (/= '\n') r+                  in go n '\n' (revApp (sym ++ line) acc) r'+             else go n (last sym) (revApp sym acc) r+      (c:r) -> go n c (c : acc) r++    isIdChar c = c == '_' || c == '\''+              || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')+              || (c >= '0' && c <= '9')++    literalBody _ [] = Left "unterminated literal in a semantic action"+    literalBody q ('\\':c:r)     = do (b, r') <- literalBody q r+                                      Right ('\\' : c : b, r')+    literalBody q (c:r) | c == q = Right ([c], r)+    literalBody q (c:r)          = do (b, r') <- literalBody q r+                                      Right (c : b, r')++    blockComment _ []              = Left "unterminated {- -} comment in a semantic action"+    blockComment k ('-':'}':r)+      | k == 1                     = Right ("-}", r)+      | otherwise                  = do (c, r') <- blockComment (k - 1) r+                                        Right ("-}" ++ c, r')+    blockComment k ('{':'-':r)     = do (c, r') <- blockComment (k + 1) r+                                        Right ("{-" ++ c, r')+    blockComment k (c:r)           = do (c', r') <- blockComment k r+                                        Right (c : c', r')++    revApp xs acc = reverse xs ++ acc++    symChars = "!#$%&*+./<=>?@\\^|-~:"++parseExpr :: P PExpr+parseExpr s0 = do+  (e1, s1) <- parseSeq s0+  loop [e1] s1+  where+    loop acc s = case tok "/" s of+      Right (_, s') -> do (e, s'') <- parseSeq s'+                          loop (e:acc) s''+      Left _        -> case reverse acc of+        [x] -> Right (x, s)+        xs  -> Right (EChoice xs, s)++parseSeq :: P PExpr+parseSeq s0 = loop [] s0+  where+    loop acc s = case parseLabelled s of+      Right (it, s') -> loop (it:acc) s'+      Left _         -> case actionLit s of+        Right (act, s') -> Right (ESeq (reverse acc) (Just act), s')+        Left _          -> Right (ESeq (reverse acc) Nothing,    s)++parseLabelled :: P Item+parseLabelled s = case label s of+  Just (l, s1) -> do (e, s2) <- parsePrefix s1+                     pure (Item (Just l) e, s2)+  Nothing      -> do (e, s1) <- parsePrefix s+                     pure (Item Nothing e, s1)+  where+    label s' = case ident s' of+      Right (name, s1) -> case tok ":" s1 of+        Right (_, s2) -> Just (name, s2)+        Left _        -> Nothing+      Left _ -> Nothing++parsePrefix :: P PExpr+parsePrefix s = case tok "&" s of+  Right (_, s') -> do (e, s'') <- parseSuffix s'; pure (EAnd e, s'')+  Left _        -> case tok "!" s of+    Right (_, s') -> do (e, s'') <- parseSuffix s'; pure (ENot e, s'')+    Left _        -> parseSuffix s++parseSuffix :: P PExpr+parseSuffix s = do+  (p, s1) <- parsePrimary s+  loop p s1+  where+    loop p s1 = case tok "?" s1 of+      Right (_, s2) -> loop (EOpt p) s2+      Left _ -> case tok "*" s1 of+        Right (_, s2) -> loop (EStar p) s2+        Left _ -> case tok "+" s1 of+          Right (_, s2) -> loop (EPlus p) s2+          Left _ -> case indented EIndent "^" p s1 of+            Right (p', s2) -> loop p' s2+            Left _ -> case indented EPos "_" p s1 of+              Right (p', s2) -> loop p' s2+              Left _         -> Right (p, s1)++    indented con marker p s1 = do+      (_, s2) <- tok marker s1+      (r, s3) <- parseRel s2+      pure (con r p, s3)++parseRel :: P RelS+parseRel s = case tok ">=" s of+  Right (_, s1) -> Right (RGe, s1)+  Left _ -> case tok ">" s of+    Right (_, s1) -> Right (RGt, s1)+    Left _ -> case tok "=" s of+      Right (_, s1) -> Right (REq, s1)+      Left _ -> case tok "~" s of+        Right (_, s1) -> Right (RAny, s1)+        Left _ -> case tok "@" s of+          Right (_, s1) -> do (name, s2) <- ident s1+                              pure (RNamed name, s2)+          Left _ -> case tok "+" s of+            Right (_, s1) -> case span isDigit (spaces s1) of+              ([], _)     -> errorAt "expected a number after '+'" s1+              (ds, s2)    -> Right (ROffset (read ds), s2)+            Left _ -> errorAt "expected an indentation relation" s+  where+    isDigit c = c >= '0' && c <= '9'++parsePrimary :: P PExpr+parsePrimary s =+  case tok "(" s of+    Right (_, s1) -> do (e, s2) <- parseExpr s1+                        (_, s3) <- tok ")" s2+                        pure (e, s3)+    Left _ -> case parseAlign s of+     Right r -> Right r+     Left _ -> case tok "." s of+      Right (_, s1) -> Right (EDot, s1)+      Left _ -> case charLit s of+        Right (c, s1) -> Right (EChar c, s1)+        Left _ -> case strLit s of+          Right (cs, s1) -> Right (EString cs, s1)+          Left _ -> case classLit s of+            Right (rs, s1) -> Right (EClass rs, s1)+            Left _ -> case ident s of+              Right (name, s1) ->+                case tok "<-" s1 of+                  Right _  -> errorAt "definition where expression expected" s+                  Left _   -> Right (ENT name, s1)+              Left _ -> errorAt "expected primary expression" s++parseAlign :: P PExpr+parseAlign s = do+  (_, s1) <- tok "|" s+  (e, s2) <- parseExpr s1+  if isEmptyExpr e+    then errorAt "empty alignment: write |e| with a non-empty e" s+    else do (_, s3) <- tok "|" s2+            pure (EAlign e, s3)+  where+    isEmptyExpr (ESeq [] Nothing) = True+    isEmptyExpr _                 = False++parseGrammar :: P [Def]+parseGrammar s0 = loop [] s0+  where+    loop acc s = case ident s of+      Left _ -> case spaces s of+        [] -> Right (reverse acc, "")+        s' -> errorAt "expected definition or end of input" s'+      Right (name, s1) -> do+        (_, s2)  <- tok "<-" s1+        (e, s3)  <- parseExpr s2+        loop (Def name e : acc) s3++translateExpr :: PExpr -> Q Exp+translateExpr (EChar c) =+  [| Term c |]+translateExpr EDot =+  [| AnyChar |]+translateExpr (ENT name) =+  pure $ TH.AppTypeE (TH.VarE 'nt) (TH.LitT (TH.StrTyLit name))+translateExpr (EString s)+  | null s    = [| pureP "" |]+  | otherwise = [| stringNE s |]+translateExpr (EClass rs) =+  let allChars = concat [ [lo..hi] | (lo, hi) <- rs ]+  in [| oneOf allChars |]+translateExpr (EAnd e)  = do+  e' <- translateExpr e+  [| Not (Not $(pure e')) |]+translateExpr (ENot e)  = do+  e' <- translateExpr e+  [| Not $(pure e') |]+translateExpr (EOpt e)  = do+  e' <- translateExpr e+  [| opt $(pure e') |]+translateExpr (EStar e) = do+  e' <- translateExpr e+  [| Star $(pure e') |]+translateExpr (EPlus e) = do+  e' <- translateExpr e+  [| plus $(pure e') |]+translateExpr (EIndent r e) = do+  e' <- translateExpr e+  [| Indent $(translateRel r) $(pure e') |]+translateExpr (EPos r e) = do+  e' <- translateExpr e+  [| Position $(translateRel r) $(pure e') |]+translateExpr (EAlign e) = do+  e' <- translateExpr e+  [| Align $(pure e') |]+translateExpr (EChoice es) = case es of+  []       -> fail "QQ: empty choice (should be impossible)"+  (e:rest) -> do+    e'    <- translateExpr e+    rest' <- mapM translateExpr rest+    foldM (\acc x -> [| $(pure acc) .||. $(pure x) |]) e' rest'+translateExpr (ESeq items act) = translateSeq items act++translateRel :: RelS -> Q Exp+translateRel RGt          = [| gtR |]+translateRel RGe          = [| geR |]+translateRel REq          = [| eqR |]+translateRel RAny         = [| anyR |]+translateRel (ROffset n)  = [| offsetR n |]+translateRel (RNamed nm)  = pure (TH.VarE (TH.mkName nm))++translateSeq :: [Item] -> Maybe String -> Q Exp+translateSeq items act = do+  let labels = [ l | Item (Just l) _ <- items ]+  case duplicates labels of+    (l:_) -> fail ("QQ: the label " ++ show l+                     ++ " is used twice in the same sequence")+    []    -> pure ()+  body <- case act of+    Nothing  -> pure (defaultBody labels)+    Just src -> case parseHsExp src of+      Right e  -> pure e+      Left err -> fail ("QQ: in the semantic action {" ++ src ++ "}: " ++ err)+  es <- mapM (\(Item _ e) -> translateExpr e) items+  case es of+    []       -> [| pureP $(pure body) |]+    (e:rest) -> do+      let pats = zipWith itemPat [1 :: Int ..] items+      hd <- [| fmapP $(pure (LamE pats body)) $(pure e) |]+      foldM (\acc x -> [| $(pure acc) <*>. $(pure x) |]) hd rest+  where+    itemPat i (Item ml _) =+      VarP (TH.mkName (maybe ('_' : show i) id ml))++    defaultBody []  = TH.ConE '()+    defaultBody [l] = TH.VarE (TH.mkName l)+    defaultBody ls  = TH.TupE (map (Just . TH.VarE . TH.mkName) ls)++    duplicates xs = [ x | x <- nub xs, length (filter (== x) xs) > 1 ]++translateRules :: [Def] -> Q Exp+translateRules [] = [| RNil |]+translateRules (Def name expr : rest) = do+  body  <- translateExpr expr+  rest' <- translateRules rest+  let nameProxy = TH.AppTypeE (TH.ConE 'Name) (TH.LitT (TH.StrTyLit name))+  [| RCons $(pure nameProxy) $(pure body) $(pure rest') |]++-- | Quasi-quoter for a single PEG expression.+--+-- @[pegExpr| body |]@ produces a 'PEG.Syntax.PExp' value.+-- Useful for one-off expressions that do not need a named rule set.+pegExpr :: QuasiQuoter+pegExpr = QuasiQuoter+  { quoteExp  = pegExprExp+  , quotePat  = \_ -> fail "pegExpr: cannot be used as a pattern"+  , quoteType = \_ -> fail "pegExpr: cannot be used as a type"+  , quoteDec  = \_ -> fail "pegExpr: cannot be used as a top-level declaration"+  }++pegExprExp :: String -> Q Exp+pegExprExp src = case parseExpr src of+  Left err     -> fail ("pegExpr: parse error: " ++ err)+  Right (e, rest) -> case spaces rest of+    []  -> translateExpr e+    leftover -> fail ("pegExpr: unconsumed input: " ++ show (take 30 leftover))++-- | Quasi-quoter for a set of named PEG rules.+--+-- @[pegRules| rule1 <- body1; rule2 <- body2 |]@ produces a+-- 'PEG.Grammar.Rules' value to be passed to 'PEG.Grammar.Grammar'.+--+-- Example:+--+-- @+-- grammar :: Grammar MyEnv _ MyResult+-- grammar = Grammar+--   [pegRules|+--     expr <- t:term ts:(op:[+-] u:term)* { foldl addOp t ts }+--     term <- n:number                     { n }+--     number <- ds:[0-9]+                  { read ds }+--   |]+--   (nt @\"expr\")+-- @+pegRules :: QuasiQuoter+pegRules = QuasiQuoter+  { quoteExp  = pegRulesExp+  , quotePat  = \_ -> fail "pegRules: cannot be used as a pattern"+  , quoteType = \_ -> fail "pegRules: cannot be used as a type"+  , quoteDec  = \_ -> fail "pegRules: cannot be used as a top-level declaration"+  }++pegRulesExp :: String -> Q Exp+pegRulesExp src = case parseGrammar src of+  Left err -> fail ("pegRules: parse error: " ++ err)+  Right (defs, _) -> translateRules defs
+ src/PEG/QQ/HsExp.hs view
@@ -0,0 +1,601 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Internal parser for Haskell expressions embedded in quasi-quoter actions.+--+-- 'parseHsExp' parses a subset of Haskell 2010 expressions sufficient to+-- handle the @{ expr }@ action blocks in 'PEG.QQ.pegRules'.+-- It is implemented without any external parsing library and depends only on+-- @base@ and @template-haskell@.+module PEG.QQ.HsExp+  ( parseHsExp+  ) where++import Data.Char           (isAlpha, isAlphaNum, isDigit, isHexDigit,+                            isOctDigit, isSpace, isUpper)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH (Body (..), Clause (..), Dec (..), Exp (..),+                            Lit (..), Match (..), Pat (..), Range (..),+                            Stmt (..), Type (..), mkName, tupleDataName,+                            tupleTypeName)++data Tok+  = TVar    String+  | TCon    String+  | TVarSym String+  | TConSym String+  | TInt    Integer+  | TRat    Rational+  | TChar   Char+  | TStr    String+  | TPunc   String+  | TRes    String+  deriving (Eq, Show)++showTok :: Tok -> String+showTok t = case t of+  TVar    s -> s+  TCon    s -> s+  TVarSym s -> s+  TConSym s -> s+  TInt    n -> show n+  TRat    r -> show (fromRational r :: Double)+  TChar   c -> show c+  TStr    s -> show s+  TPunc   s -> s+  TRes    s -> s++atTok :: [Tok] -> String+atTok []      = "at the end of the action"+atTok (t : _) = "at " ++ show (showTok t)++symChars :: String+symChars = "!#$%&*+./<=>?@\\^|-~:"++reservedOps :: [String]+reservedOps = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]++reservedIds :: [String]+reservedIds =+  [ "case", "class", "data", "default", "deriving", "do", "else"+  , "foreign", "if", "import", "in", "infix", "infixl", "infixr"+  , "instance", "let", "module", "newtype", "of", "then", "type"+  , "where", "_"+  ]++lexHs :: String -> Either String [Tok]+lexHs = go+  where+    go [] = Right []++    go s@(c : cs)+      | isSpace c = go cs+      | c == '{', ('-' : cs') <- cs = skipBlock (1 :: Int) cs' >>= go+      | c == '\'' = lexChar s+      | c == '"'  = lexString s+      | isDigit c = lexNumber s+      | isAlpha c || c == '_' = lexIdent s+      | c == '`' = lexBacktick cs+      | c `elem` "()[],;{}" = (TPunc [c] :) <$> go cs+      | c `elem` symChars =+          let (sym, rest) = span (`elem` symChars) s+          in if all (== '-') sym && length sym >= 2+               then go (dropWhile (/= '\n') rest)+               else (classifySym sym :) <$> go rest+      | otherwise = Left ("unexpected character " ++ show c ++ " in action")++    skipBlock :: Int -> String -> Either String String+    skipBlock 0 s               = Right s+    skipBlock _ []              = Left "unterminated {- -} comment in action"+    skipBlock n ('-' : '}' : s) = skipBlock (n - 1) s+    skipBlock n ('{' : '-' : s) = skipBlock (n + 1) s+    skipBlock n (_ : s)         = skipBlock n s++    lexChar s = case reads s :: [(Char, String)] of+      [(ch, rest)] -> (TChar ch :) <$> go rest+      _            -> Left ("malformed character literal in action: "+                              ++ show (take 10 s))++    lexString s = case reads s :: [(String, String)] of+      [(str, rest)] -> (TStr str :) <$> go rest+      _             -> Left ("malformed string literal in action: "+                               ++ show (take 10 s))++    lexIdent s =+      let (name, rest) = spanIdent s+      in case rest of+           ('.' : c' : _) | startsUpper name+                          , isAlpha c' || c' == '_' ->+             let (rest', qual) = lexQual name (drop 1 rest)+             in (qual :) <$> go rest'+           ('.' : c' : _) | startsUpper name+                          , c' `elem` symChars ->+             let (sym, rest') = span (`elem` symChars) (drop 1 rest)+             in (classifyQualSym name sym :) <$> go rest'+           _ | name `elem` reservedIds -> (TRes name :) <$> go rest+             | startsUpper name        -> (TCon name :) <$> go rest+             | otherwise               -> (TVar name :) <$> go rest++    lexQual acc s =+      let (name, rest) = spanIdent s+          acc'         = acc ++ "." ++ name+      in case rest of+           ('.' : c' : _) | startsUpper name+                          , isAlpha c' || c' == '_' -> lexQual acc' (drop 1 rest)+           _ | startsUpper name -> (rest, TCon acc')+             | otherwise           -> (rest, TVar acc')++    lexBacktick s =+      let (name, rest) = spanIdent s+      in case rest of+           ('`' : rest')+             | null name -> Left "empty backticked operator in action"+             | startsUpper name -> (TConSym name :) <$> go rest'+             | otherwise           -> (TVarSym name :) <$> go rest'+           _ -> Left "unterminated backticked operator in action"++    classifySym sym+      | sym `elem` reservedOps = TRes sym+      | take 1 sym == ":"      = TConSym sym+      | otherwise              = TVarSym sym++    classifyQualSym m sym+      | take 1 sym == ":" = TConSym (m ++ "." ++ sym)+      | otherwise         = TVarSym (m ++ "." ++ sym)++    lexNumber s =+      case s of+        ('0' : x : rest) | x `elem` "xX", (ds, r) <- span isHexDigit rest, not (null ds) ->+          (TInt (readBase 16 ds) :) <$> go r+        ('0' : o : rest) | o `elem` "oO", (ds, r) <- span isOctDigit rest, not (null ds) ->+          (TInt (readBase 8 ds) :) <$> go r+        ('0' : b : rest) | b `elem` "bB", (ds, r) <- span (`elem` "01") rest, not (null ds) ->+          (TInt (readBase 2 ds) :) <$> go r+        _ ->+          let (whole, r1) = span isDigit s+          in case r1 of+               ('.' : d : _) | isDigit d ->+                 let (frac, r2) = span isDigit (drop 1 r1)+                     (expo, r3) = lexExponent r2+                 in (TRat (mkRat whole frac (maybe 0 id expo)) :) <$> go r3+               _ | (Just expo, r2) <- lexExponent r1 ->+                     (TRat (mkRat whole "" expo) :) <$> go r2+                 | otherwise -> (TInt (read whole) :) <$> go r1++    mkRat whole frac expo =+      let mantissa = read (whole ++ frac) :: Integer+          scale    = expo - toInteger (length frac)+      in if scale >= 0+           then toRational (mantissa * 10 ^ scale)+           else toRational mantissa / toRational (10 ^ negate scale :: Integer)++    lexExponent s@(e : rest)+      | e `elem` "eE" =+          case rest of+            ('+' : ds) | (n@(_ : _), r) <- span isDigit ds -> (Just (read n), r)+            ('-' : ds) | (n@(_ : _), r) <- span isDigit ds -> (Just (negate (read n)), r)+            _ | (n@(_ : _), r) <- span isDigit rest -> (Just (read n), r)+            _ -> (Nothing, s)+    lexExponent s = (Nothing, s)++    readBase :: Integer -> String -> Integer+    readBase b = foldl (\acc d -> acc * b + toInteger (digitVal d)) 0++    digitVal d+      | isDigit d = fromEnum d - fromEnum '0'+      | otherwise = 10 + fromEnum (toLowerAscii d) - fromEnum 'a'++    toLowerAscii ch+      | ch >= 'A' && ch <= 'Z' = toEnum (fromEnum ch + 32)+      | otherwise              = ch++startsUpper :: String -> Bool+startsUpper (c : _) = isUpper c+startsUpper []      = False++spanIdent :: String -> (String, String)+spanIdent s =+  let (c, cs) = splitAt 1 s+      (n, r)  = span (\x -> isAlphaNum x || x == '_' || x == '\'') cs+  in (c ++ n, r)++type P a = [Tok] -> Either String (a, [Tok])++parseHsExp :: String -> Either String Exp+parseHsExp src = do+  toks <- lexHs src+  case toks of+    [] -> Left "empty semantic action"+    _  -> do+      (e, rest) <- pExp toks+      case rest of+        [] -> Right e+        _  -> Left ("unconsumed input in action " ++ atTok rest)++pExp :: P Exp+pExp toks = do+  (e, mop, rest) <- pOpChain toks+  case mop of+    Just op -> Left ("dangling operator " ++ show (pprExp op) ++ " in action")+    Nothing -> case rest of+      (TRes "::" : rest') -> do+        (ty, rest'') <- pType rest'+        Right (SigE e ty, rest'')+      _ -> Right (e, rest)++pOpChain :: [Tok] -> Either String (Exp, Maybe Exp, [Tok])+pOpChain toks = do+  (e, rest) <- pOperand toks+  go [e] [] rest+  where+    go operands ops rest = case rest of+      (t : rest') | Just op <- opExpOf t ->+        if startsOperand rest'+          then do+            (e', rest'') <- pOperand rest'+            go (e' : operands) (op : ops) rest''+          else Right (build (reverse operands) (reverse ops), Just op, rest')+      _ -> Right (build (reverse operands) (reverse ops), Nothing, rest)++    build [e]           _          = e+    build (e : es)      (op : ops) = UInfixE e op (build es ops)+    build _             _          = error "PEG.QQ.HsExp: impossible operator chain"++opExpOf :: Tok -> Maybe Exp+opExpOf (TVarSym s) = Just (VarE (mkName s))+opExpOf (TConSym s) = Just (ConE (mkName s))+opExpOf _           = Nothing++pOperand :: P Exp+pOperand (TVarSym "-" : rest) = do+  (e, rest') <- pOperand rest+  Right (AppE (VarE 'negate) e, rest')+pOperand toks@(TRes "\\" : _)   = pLambda toks+pOperand toks@(TRes "let" : _)  = pLet toks+pOperand toks@(TRes "if" : _)   = pIf toks+pOperand toks@(TRes "case" : _) = pCase toks+pOperand (TRes "do" : _) =+  Left "'do' notation is not supported in a semantic action"+pOperand (TRes "where" : _) =+  Left "'where' is not supported in a semantic action; use 'let ... in' instead"+pOperand toks = pApp toks++startsOperand :: [Tok] -> Bool+startsOperand []      = False+startsOperand (t : _) = case t of+  TVarSym "-" -> True+  TRes r      -> r `elem` ["\\", "let", "if", "case"]+  _           -> startsAExp t++startsAExp :: Tok -> Bool+startsAExp t = case t of+  TVar  _   -> True+  TCon  _   -> True+  TInt  _   -> True+  TRat  _   -> True+  TChar _   -> True+  TStr  _   -> True+  TPunc "(" -> True+  TPunc "[" -> True+  _         -> False++pApp :: P Exp+pApp toks = do+  (f, rest) <- pAExp toks+  go f rest+  where+    go acc rest@(t : _) | startsAExp t = do+      (x, rest') <- pAExp rest+      go (AppE acc x) rest'+    go acc rest = Right (acc, rest)++pAExp :: P Exp+pAExp (TVar  s : rest) = Right (VarE (mkName s), rest)+pAExp (TCon  s : rest) = Right (ConE (mkName s), rest)+pAExp (TInt  n : rest) = Right (LitE (IntegerL n), rest)+pAExp (TRat  r : rest) = Right (LitE (RationalL r), rest)+pAExp (TChar c : rest) = Right (LitE (CharL c), rest)+pAExp (TStr  s : rest) = Right (LitE (StringL s), rest)+pAExp (TPunc "(" : rest) = pParen rest+pAExp (TPunc "[" : rest) = pBracket rest+pAExp toks = Left ("expected an expression " ++ atTok toks)++pParen :: P Exp+pParen (TPunc ")" : rest) = Right (ConE '(), rest)+pParen toks@(TPunc "," : _) =+  let (commas, rest) = span (== TPunc ",") toks+  in case rest of+       (TPunc ")" : rest') -> Right (ConE (tupleDataName (length commas + 1)), rest')+       _ -> Left ("expected ')' after a tuple constructor " ++ atTok rest)+pParen (t : rest)+  | Just op <- opExpOf t+  , t /= TVarSym "-" =+      case rest of+        (TPunc ")" : rest') -> Right (op, rest')+        _ -> do+          (e, rest') <- pExp rest+          rest'' <- expect (TPunc ")") rest'+          Right (InfixE Nothing op (Just e), rest'')+pParen toks = do+  (e, mop, rest) <- pOpChain toks+  case mop of+    Just op -> do+      rest' <- expect (TPunc ")") rest+      Right (InfixE (Just e) op Nothing, rest')+    Nothing -> case rest of+      (TRes "::" : rest') -> do+        (ty, rest'') <- pType rest'+        rest''' <- expect (TPunc ")") rest''+        Right (ParensE (SigE e ty), rest''')+      (TPunc ")" : rest') -> Right (ParensE e, rest')+      (TPunc "," : _)     -> do+        (es, rest') <- pCommaList pExp rest+        rest'' <- expect (TPunc ")") rest'+        Right (TupE (map Just (e : es)), rest'')+      _ -> Left ("expected ')' or ',' " ++ atTok rest)++pBracket :: P Exp+pBracket (TPunc "]" : rest) = Right (ListE [], rest)+pBracket toks = do+  (e, rest) <- pExp toks+  case rest of+    (TPunc "]" : rest') -> Right (ListE [e], rest')+    (TRes ".." : rest') -> case rest' of+      (TPunc "]" : rest'') -> Right (ArithSeqE (FromR e), rest'')+      _ -> do+        (hi, rest'') <- pExp rest'+        rest''' <- expect (TPunc "]") rest''+        Right (ArithSeqE (FromToR e hi), rest''')+    (TRes "|" : rest') -> do+      (quals, rest'') <- pCommaList1 pQual rest'+      rest''' <- expect (TPunc "]") rest''+      Right (CompE (quals ++ [NoBindS e]), rest''')+    (TPunc "," : rest') -> do+      (e2, rest'') <- pExp rest'+      case rest'' of+        (TRes ".." : rest''') -> case rest''' of+          (TPunc "]" : r) -> Right (ArithSeqE (FromThenR e e2), r)+          _ -> do+            (hi, r) <- pExp rest'''+            r' <- expect (TPunc "]") r+            Right (ArithSeqE (FromThenToR e e2 hi), r')+        (TPunc "]" : r) -> Right (ListE [e, e2], r)+        (TPunc "," : r) -> do+          (es, r') <- pCommaList pExp r+          r'' <- expect (TPunc "]") r'+          Right (ListE (e : e2 : es), r'')+        _ -> Left ("expected ']' or ',' in a list " ++ atTok rest'')+    _ -> Left ("expected ']' " ++ atTok rest)++pQual :: P Stmt+pQual (TRes "let" : rest) = do+  (ds, rest') <- pDecls rest+  Right (LetS ds, rest')+pQual toks =+  case pPat toks of+    Right (p, TRes "<-" : rest) -> do+      (e, rest') <- pExp rest+      Right (BindS p e, rest')+    _ -> do+      (e, rest) <- pExp toks+      Right (NoBindS e, rest)++pLambda :: P Exp+pLambda (TRes "\\" : rest) = do+  (ps, rest') <- pApats rest+  case ps of+    [] -> Left "a lambda needs at least one argument"+    _  -> do+      rest'' <- expect (TRes "->") rest'+      (e, rest''') <- pExp rest''+      Right (LamE ps e, rest''')+pLambda toks = Left ("expected a lambda " ++ atTok toks)++pIf :: P Exp+pIf (TRes "if" : rest) = do+  (c, rest1) <- pExp rest+  rest2      <- expect (TRes "then") rest1+  (t, rest3) <- pExp rest2+  rest4      <- expect (TRes "else") rest3+  (e, rest5) <- pExp rest4+  Right (CondE c t e, rest5)+pIf toks = Left ("expected 'if' " ++ atTok toks)++pLet :: P Exp+pLet (TRes "let" : rest) = do+  (ds, rest') <- pDecls rest+  rest''      <- expect (TRes "in") rest'+  (e, rest''') <- pExp rest''+  Right (LetE ds e, rest''')+pLet toks = Left ("expected 'let' " ++ atTok toks)++pCase :: P Exp+pCase (TRes "case" : rest) = do+  (scrut, rest1) <- pExp rest+  rest2 <- expect (TRes "of") rest1+  case rest2 of+    (TPunc "{" : rest3) -> do+      (alts, rest4) <- pSemiList pAlt rest3+      rest5 <- expect (TPunc "}") rest4+      Right (CaseE scrut alts, rest5)+    _ -> Left "'case' inside a semantic action needs explicit braces"+pCase toks = Left ("expected 'case' " ++ atTok toks)++pAlt :: P Match+pAlt toks = do+  (p, rest)   <- pPat toks+  rest'       <- expect (TRes "->") rest+  (e, rest'') <- pExp rest'+  Right (Match p (NormalB e) [], rest'')++pDecls :: P [Dec]+pDecls (TPunc "{" : rest) = do+  (ds, rest') <- pSemiList pDecl rest+  rest'' <- expect (TPunc "}") rest'+  Right (ds, rest'')+pDecls toks = pSemiList pDecl toks++pDecl :: P Dec+pDecl (TVar f : rest) = do+  (ps, rest') <- pApats rest+  case rest' of+    (TRes "=" : rest'') -> do+      (e, rest''') <- pExp rest''+      Right ( if null ps+                then ValD (VarP (mkName f)) (NormalB e) []+                else FunD (mkName f) [Clause ps (NormalB e) []]+            , rest''' )+    _ -> Left ("expected '=' in a let binding " ++ atTok rest')+pDecl toks = do+  (p, rest) <- pPat toks+  rest'     <- expect (TRes "=") rest+  (e, rest'') <- pExp rest'+  Right (ValD p (NormalB e) [], rest'')++pPat :: P Pat+pPat toks = do+  (p, rest) <- pPat10+  go p rest+  where+    pPat10 = case toks of+      (TCon c : rest) -> do+        (ps, rest') <- pApats rest+        Right (if null ps then ConP (mkName c) [] [] else ConP (mkName c) [] ps, rest')+      _ -> pApat toks++    go p (TConSym op : rest) = do+      (q, rest') <- pPat rest+      Right (UInfixP p (mkName op) q, rest')+    go p rest = Right (p, rest)++pApats :: P [Pat]+pApats toks = go [] toks+  where+    go acc rest+      | startsApat rest = do+          (p, rest') <- pApat rest+          go (p : acc) rest'+      | otherwise = Right (reverse acc, rest)++    startsApat (t : _) = case t of+      TVar  _   -> True+      TCon  _   -> True+      TInt  _   -> True+      TChar _   -> True+      TStr  _   -> True+      TRes  "_" -> True+      TRes  "~" -> True+      TPunc "(" -> True+      TPunc "[" -> True+      _         -> False+    startsApat [] = False++pApat :: P Pat+pApat (TRes "_" : rest)  = Right (WildP, rest)+pApat (TRes "~" : rest)  = do+  (p, rest') <- pApat rest+  Right (TildeP p, rest')+pApat (TVar v : TRes "@" : rest) = do+  (p, rest') <- pApat rest+  Right (AsP (mkName v) p, rest')+pApat (TVar  v : rest) = Right (VarP (mkName v), rest)+pApat (TCon  c : rest) = Right (ConP (mkName c) [] [], rest)+pApat (TInt  n : rest) = Right (LitP (IntegerL n), rest)+pApat (TChar c : rest) = Right (LitP (CharL c), rest)+pApat (TStr  s : rest) = Right (LitP (StringL s), rest)+pApat (TPunc "(" : TPunc ")" : rest) = Right (ConP '() [] [], rest)+pApat (TPunc "(" : rest) = do+  (p, rest') <- pPat rest+  case rest' of+    (TPunc ")" : rest'') -> Right (p, rest'')+    (TPunc "," : _)      -> do+      (ps, rest'') <- pCommaList pPat rest'+      rest''' <- expect (TPunc ")") rest''+      Right (TupP (p : ps), rest''')+    _ -> Left ("expected ')' in a pattern " ++ atTok rest')+pApat (TPunc "[" : TPunc "]" : rest) = Right (ListP [], rest)+pApat (TPunc "[" : rest) = do+  (p, rest')  <- pPat rest+  (ps, rest'') <- pCommaList pPat rest'+  rest''' <- expect (TPunc "]") rest''+  Right (ListP (p : ps), rest''')+pApat toks = Left ("expected a pattern " ++ atTok toks)++pType :: P Type+pType toks = do+  (t, rest) <- pBType toks+  case rest of+    (TRes "->" : rest') -> do+      (u, rest'') <- pType rest'+      Right (AppT (AppT ArrowT t) u, rest'')+    _ -> Right (t, rest)++pBType :: P Type+pBType toks = do+  (t, rest) <- pAType toks+  go t rest+  where+    go acc rest@(u : _) | startsAType u = do+      (x, rest') <- pAType rest+      go (AppT acc x) rest'+    go acc rest = Right (acc, rest)++    startsAType t = case t of+      TCon  _   -> True+      TVar  _   -> True+      TPunc "(" -> True+      TPunc "[" -> True+      _         -> False++pAType :: P Type+pAType (TCon c : rest) = Right (ConT (mkName c), rest)+pAType (TVar v : rest) = Right (VarT (mkName v), rest)+pAType (TPunc "(" : TPunc ")" : rest) = Right (ConT ''(), rest)+pAType (TPunc "(" : rest) = do+  (t, rest') <- pType rest+  case rest' of+    (TPunc ")" : rest'') -> Right (t, rest'')+    (TPunc "," : _)      -> do+      (ts, rest'') <- pCommaList pType rest'+      rest''' <- expect (TPunc ")") rest''+      let n = length ts + 1+      Right (foldl AppT (ConT (tupleTypeName n)) (t : ts), rest''')+    _ -> Left ("expected ')' in a type " ++ atTok rest')+pAType (TPunc "[" : TPunc "]" : rest) = Right (ListT, rest)+pAType (TPunc "[" : rest) = do+  (t, rest') <- pType rest+  rest'' <- expect (TPunc "]") rest'+  Right (AppT ListT t, rest'')+pAType toks = Left ("expected a type " ++ atTok toks)++expect :: Tok -> [Tok] -> Either String [Tok]+expect t (t' : rest) | t == t' = Right rest+expect t toks = Left ("expected " ++ show (showTok t) ++ " " ++ atTok toks)++pCommaList1 :: P a -> P [a]+pCommaList1 p toks = do+  (x, rest)   <- p toks+  (xs, rest') <- pCommaList p rest+  Right (x : xs, rest')++pCommaList :: P a -> P [a]+pCommaList p = go []+  where+    go acc (TPunc "," : rest) = do+      (x, rest') <- p rest+      go (x : acc) rest'+    go acc rest = Right (reverse acc, rest)++pSemiList :: P a -> P [a]+pSemiList p toks = do+  (x, rest) <- p toks+  go [x] rest+  where+    go acc (TPunc ";" : rest) = do+      (y, rest') <- p rest+      go (y : acc) rest'+    go acc rest = Right (reverse acc, rest)++pprExp :: Exp -> String+pprExp (VarE n) = TH.nameBase n+pprExp (ConE n) = TH.nameBase n+pprExp e        = show e
+ src/PEG/Semantics/Simple.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleInstances, DeriveFunctor, TypeFamilies #-}+-- | A simple, continuation-based semantics for PEG expressions.+--+-- 'PExp' in this module is an alternative representation of PEG expressions+-- as explicit functions over an input type @d@, making the semantics of each+-- combinator concrete and inspectable.  Useful for testing and for+-- understanding the library\'s evaluation model.+module PEG.Semantics.Simple where++import Control.Applicative+import Control.Monad (MonadPlus(..), guard)+import Data.Char (isDigit, ord, isSpace)+import Prelude hiding (not)++newtype PExp d a+  = PExp {+      runPExp :: d -> Result d a+    } deriving Functor++data Result d a+  = Pure a             -- didn't consume anything, can backtrack+  | Commit d a         -- consumed input+  | Fail String Bool   -- failed, flagged if consumed+  deriving Functor++instance Applicative (PExp d) where+  pure a = PExp $ \ _ -> Pure a+  PExp mf <*> PExp ma+    = PExp $ \ d ->+      case mf d of+        Pure f      -> fmap f (ma d)+        Fail s c    -> Fail s c+        Commit d' f ->+          case ma d' of+            Pure a       -> Commit d' (f a)+            Fail s _     -> Fail s True+            Commit d'' a -> Commit d'' (f a)++instance Alternative (PExp d) where+  PExp ma <|> PExp mb+    = PExp $ \ d ->+      case ma d of+        Fail _ False -> mb d+        x            -> x+  empty = PExp $ \ _ -> Fail "empty" False+++instance Monad (PExp d) where+  PExp m >>= k = PExp $ \d ->+    case m d of+      Pure a -> runPExp (k a) d+      Commit d' a ->+        case runPExp (k a) d' of+          Pure b -> Commit d' b+          Fail s _ -> Fail s True+          commit -> commit+      Fail s c -> Fail s c++instance MonadPlus (PExp d) where+  mplus = (<|>)+  mzero = empty++try :: PExp d a -> PExp d a+try (PExp m)+  = PExp $ \d ->+      case m d of+        Fail s _ -> Fail s False+        x        -> x++infixl 3 </>++(</>) :: PExp d a -> PExp d a -> PExp d a+p </> q = try p <|> q+++class Stream d where+  type Elem d+  anyChar :: PExp d (Elem d)++instance Stream [a] where+  type Elem [a] = a +  anyChar = PExp $ \s -> case s of+    (x:xs) -> Commit xs x+    [] -> Fail "EOF" False++satisfy :: Stream d => (Elem d -> Bool) -> PExp d (Elem d)+satisfy p = try $ do+  x <- anyChar+  x <$ guard (p x)++whiteSpace :: PExp String ()+whiteSpace = () <$ many (satisfy isSpace)++phrase :: PExp String a -> PExp String a+phrase m = whiteSpace *> m <* eof++not :: PExp d a -> PExp d ()+not (PExp m)+  = PExp $ \d ->+      case m d of+        Fail{} -> Pure ()+        _      -> Fail "unexpected" False++eof :: Stream d => PExp d ()+eof = not anyChar++char :: Eq (Elem d) => Stream d => Elem d -> PExp d (Elem d)+char c = satisfy (c ==)++lexeme :: PExp String a -> PExp String a+lexeme m = m <* whiteSpace++symbol :: Char -> PExp String Char+symbol c = lexeme (char c)++digit :: PExp String Int+digit+  = f <$> satisfy isDigit+    where+      f c = ord c - ord '0'
+ src/PEG/Syntax.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances   #-}++-- | The PEG expression GADT and combinator API.+--+-- 'PExp' is the core type: a GADT indexed by the grammar environment,+-- the 'PEG.Type.Ty' of the expression (nullability + FIRST set), and the+-- Haskell result type.  Combinators like '<*>.' and '.||.' propagate type+-- information at the kind level so that 'PEG.Grammar.Acyclic' can be checked+-- without running the parser.+--+-- Most users will not build 'PExp' values directly; instead they use the+-- quasi-quoter in "PEG.QQ".+module PEG.Syntax+  ( Name (..)+  , PExp (..)+  , nt+  , pureP+  , fmapP+  , indent+  , position+  , align+  , (<$>.)+  , (<*>.)+  , (.>>.)+  , (.||.)+  , opt+  , plus+  , oneOf+  , stringNE+  , SeqTy+  , ChoiceTy+  , NTTy+  ) where++import Data.Kind    (Type)+import GHC.TypeLits (Symbol, KnownSymbol)++import PEG.Indent (Rel)+import PEG.Type+import PEG.TyLevel+import PEG.Member++-- | A singleton witness for a non-terminal name @s@.+data Name (s :: Symbol) = Name++-- | The 'Ty' of a sequence @e1 e2@.+type SeqTy t1 t2 =+  'MkTy (And (Nullable t1) (Nullable t2))+        (Union (First t1) (If (Nullable t1) (First t2) '[]))++-- | The 'Ty' of an ordered choice @e1 \/ e2@.+type ChoiceTy t1 t2 =+  'MkTy (Or  (Nullable t1) (Nullable t2))+        (Union (First t1) (First t2))++-- | The 'Ty' of a non-terminal reference @s@ looked up in @env@.+type NTTy s env =+  'MkTy (Nullable (TyOf (Lookup s env)))+        (ConsIfAbsent s (First (TyOf (Lookup s env))))++-- | A typed PEG expression.+--+-- Constructors correspond to the standard PEG operators:+--+-- * 'Pure'   — succeed without consuming input, return a value+-- * 'Term'   — match a specific character+-- * 'AnyChar'— match any character+-- * 'NT'     — invoke a named non-terminal+-- * 'Seq'    — sequential composition (@e1 e2@)+-- * 'Choice' — ordered choice (@e1 \/ e2@)+-- * 'Star'   — Kleene star (@e*@)+-- * 'Not'    — negative lookahead (@!e@)+-- * 'Map'    — apply a function to the result+-- * 'Indent' — require the next token to satisfy an indentation relation+-- * 'Position'— set the column relation for tokens inside the sub-expression+-- * 'Align'  — require the next token to be aligned with the current position+data PExp (env :: Env) (ty :: Ty) (a :: Type) where+  Pure     :: a -> PExp env ('MkTy 'True '[]) a+  Term     :: Char -> PExp env ('MkTy 'False '[]) Char+  AnyChar  :: PExp env ('MkTy 'False '[]) Char+  NT       :: ( KnownSymbol s+              , KnownMember s env (TyOf (Lookup s env)) (ResOf (Lookup s env))+              )+           => Name s+           -> PExp env (NTTy s env) (ResOf (Lookup s env))+  Seq      :: PExp env t1 (a -> b)+           -> PExp env t2 a+           -> PExp env (SeqTy t1 t2) b+  Choice   :: PExp env t1 a+           -> PExp env t2 a+           -> PExp env (ChoiceTy t1 t2) a+  Star     :: PExp env ('MkTy 'False f) a+           -> PExp env ('MkTy 'True  f) [a]+  Not      :: PExp env ('MkTy n f) a+           -> PExp env ('MkTy 'True f) ()+  Map      :: (a -> b)+           -> PExp env ty a+           -> PExp env ty b+  Indent   :: Rel n+           -> PExp env ty a+           -> PExp env ty a+  Position :: Rel n+           -> PExp env ty a+           -> PExp env ty a+  Align    :: PExp env ty a+           -> PExp env ty a++instance Functor (PExp env ty) where+  fmap = Map++-- | Reference a non-terminal by name using a type application:+-- @nt \@\"ruleName\"@.+nt :: forall s env.+      ( KnownSymbol s+      , KnownMember s env (TyOf (Lookup s env)) (ResOf (Lookup s env))+      )+   => PExp env (NTTy s env) (ResOf (Lookup s env))+nt = NT (Name :: Name s)++-- | Succeed without consuming any input.+pureP :: a -> PExp env ('MkTy 'True '[]) a+pureP = Pure++-- | Apply a function to the result of an expression.+fmapP :: (a -> b) -> PExp env ty a -> PExp env ty b+fmapP = Map++-- | Require the sub-expression to satisfy the given column relation.+indent :: Rel n -> PExp env ty a -> PExp env ty a+indent = Indent++-- | Override the token mode for the sub-expression.+position :: Rel n -> PExp env ty a -> PExp env ty a+position = Position++-- | Require the sub-expression to start at the current alignment column.+align :: PExp env ty a -> PExp env ty a+align = Align++-- | Infix synonym for 'fmapP'.+(<$>.) :: (a -> b) -> PExp env ty a -> PExp env ty b+(<$>.) = Map+infixl 4 <$>.++-- | Infix sequential composition.+(<*>.) :: PExp env t1 (a -> b)+       -> PExp env t2 a+       -> PExp env (SeqTy t1 t2) b+(<*>.) = Seq+infixl 4 <*>.++-- | Sequence two expressions, discarding the result of the first.+(.>>.) :: PExp env t1 a+       -> PExp env t2 b+       -> PExp env (SeqTy t1 t2) b+e1 .>>. e2 = Map (\_ b -> b) e1 <*>. e2+infixl 6 .>>.++-- | Infix ordered choice (@e1 \/ e2@): try @e1@; if it fails, try @e2@.+(.||.) :: PExp env t1 a -> PExp env t2 a -> PExp env (ChoiceTy t1 t2) a+(.||.) = Choice+infixl 5 .||.++-- | Optional match: @opt e = (Just \<$\>. e) .||. pureP Nothing@.+opt :: PExp env t a+    -> PExp env (ChoiceTy t ('MkTy 'True '[])) (Maybe a)+opt e = (Just <$>. e) .||. pureP Nothing++-- | One-or-more: @plus e = (:) \<$\>. e \<*\>. Star e@.+plus :: PExp env ('MkTy 'False f) a+     -> PExp env (SeqTy ('MkTy 'False f) ('MkTy 'True f)) [a]+plus e = (:) <$>. e <*>. Star e++-- | Match any character in the given list. The list must be non-empty.+oneOf :: [Char] -> PExp env ('MkTy 'False '[]) Char+oneOf []     = error "PEG.Syntax.oneOf: empty character class"+oneOf [c]    = Term c+oneOf (c:cs) = Term c .||. oneOf cs++-- | Match an exact string literal. The string must be non-empty.+stringNE :: String -> PExp env ('MkTy 'False '[]) String+stringNE []     = error "PEG.Syntax.stringNE: empty string"+stringNE [c]    = (\x -> [x]) <$>. Term c+stringNE (c:cs) = (:) <$>. Term c <*>. stringNE cs
+ src/PEG/TyLevel.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Type-level utilities: boolean logic, symbol equality, set operations,+-- and environment lookup.+--+-- These type families are used internally to compute the FIRST sets and+-- nullability of PEG expressions at the kind level, enabling the+-- 'PEG.Grammar.Acyclic' constraint to be resolved at compile time.+module PEG.TyLevel+  ( If+  , And+  , Or+  , SymEq+  , Elem+  , Union+  , ConsIfAbsent+  , Lookup+  , Names+  ) where++import GHC.TypeLits (CmpSymbol, ErrorMessage (..), Symbol, TypeError)++import PEG.Type++type family If (c :: Bool) (t :: k) (e :: k) :: k where+  If 'True  t _ = t+  If 'False _ e = e++type family And (a :: Bool) (b :: Bool) :: Bool where+  And 'True  b = b+  And 'False _ = 'False++type family Or (a :: Bool) (b :: Bool) :: Bool where+  Or 'True  _ = 'True+  Or 'False b = b++type family SymEq (a :: Symbol) (b :: Symbol) :: Bool where+  SymEq a b = IsEQ (CmpSymbol a b)++type family IsEQ (o :: Ordering) :: Bool where+  IsEQ 'EQ = 'True+  IsEQ _   = 'False++type family Elem (x :: Symbol) (xs :: [Symbol]) :: Bool where+  Elem _ '[]       = 'False+  Elem x (y ': ys) = Or (SymEq x y) (Elem x ys)++type family ConsIfAbsent (x :: Symbol) (xs :: [Symbol]) :: [Symbol] where+  ConsIfAbsent x xs = If (Elem x xs) xs (x ': xs)++type family Union (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where+  Union '[]       ys = ys+  Union (x ': xs) ys = ConsIfAbsent x (Union xs ys)++type family Lookup (s :: Symbol) (env :: Env) :: EnvEntry where+  Lookup s env = LookupGo s env env++type family LookupGo (s :: Symbol) (env :: Env) (full :: Env) :: EnvEntry where+  LookupGo s '[] full =+    TypeError ('Text "Undefined non-terminal: " ':<>: 'ShowType s+         ':$$: 'Text "Available non-terminals: " ':<>: 'ShowType (Names full))+  LookupGo s ('(t, e) ': rest) full = LookupStep (SymEq s t) s e rest full++type family LookupStep (b :: Bool) (s :: Symbol) (e :: EnvEntry)+                       (rest :: Env) (full :: Env) :: EnvEntry where+  LookupStep 'True  _ e _    _    = e+  LookupStep 'False s _ rest full = LookupGo s rest full++type family Names (env :: Env) :: [Symbol] where+  Names '[]               = '[]+  Names ('(s, _) ': rest) = s ': Names rest
+ src/PEG/Type.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE TypeOperators  #-}++-- | Type-level representation of PEG type information.+--+-- Each non-terminal carries a 'Ty': a pair of its /nullability/+-- (can it match the empty string?) and its /FIRST set/ (which non-terminal+-- names can appear at the head of a derivation?).+-- Both pieces of information are tracked as type-level data and used by the+-- 'PEG.Grammar.Acyclic' constraint to reject left-recursive grammars at+-- compile time.+module PEG.Type+  ( Ty (..)+  , Nullable+  , First+  , EnvEntry (..)+  , Env+  , TyOf+  , ResOf+  ) where++import Data.Kind    (Type)+import GHC.TypeLits (Symbol)++-- | A PEG type: nullability flag and FIRST set.+--+-- @'MkTy' n fs@ means the expression may match the empty string iff @n ~ 'True@,+-- and the set of non-terminal names that can begin a derivation is @fs@.+data Ty = MkTy Bool [Symbol]++-- | Extract the nullability flag from a 'Ty'.+type family Nullable (t :: Ty) :: Bool where+  Nullable ('MkTy n _) = n++-- | Extract the FIRST set (list of non-terminal names) from a 'Ty'.+type family First (t :: Ty) :: [Symbol] where+  First ('MkTy _ f) = f++-- | An entry in the grammar environment: a 'Ty' paired with its result type.+data EnvEntry = EnvEntry Ty Type++-- | A grammar environment: a type-level association list mapping non-terminal+-- names ('Symbol') to their 'EnvEntry'.+type Env = [(Symbol, EnvEntry)]++-- | Extract the 'Ty' from an 'EnvEntry'.+type family TyOf (e :: EnvEntry) :: Ty where+  TyOf ('EnvEntry t _) = t++-- | Extract the result type from an 'EnvEntry'.+type family ResOf (e :: EnvEntry) :: Type where+  ResOf ('EnvEntry _ a) = a
+ typed-peg.cabal view
@@ -0,0 +1,77 @@+cabal-version:      3.0+name:               typed-peg+version:            0.1.0.0+synopsis:           Type-safe PEG parser combinators+description:+  A library for building PEG (Parsing Expression Grammar) parsers+  with compile-time safety guarantees. Grammar non-terminals are+  indexed by their nullability and FIRST sets at the type level,+  making left-recursive grammars a type error.+  .+  A quasi-quoter ('PEG.QQ') allows writing grammars in a concrete+  DSL syntax. Indentation-sensitive parsing is supported natively+  via 'PEG.Indent'.++license:            BSD-3-Clause+license-file:       LICENSE+author:             Rodrigo Ribeiro+maintainer:         rodrigo.ribeiro@ufop.edu.br+category:           Parsing+homepage:           https://github.com/rodrigogribeiro/typed-peg+bug-reports:        https://github.com/rodrigogribeiro/typed-peg/issues+build-type:         Simple+extra-source-files: README.md+extra-doc-files:    CHANGELOG.md+tested-with:        GHC == 9.6.7++source-repository head+  type:     git+  location: https://github.com/rodrigogribeiro/typed-peg++common common-opts+  ghc-options:+    -Wall+    -Wno-partial-type-signatures+    -Wno-unrecognised-pragmas+  default-language:   Haskell2010+  default-extensions:+    DataKinds+    GADTs+    TypeFamilies+    TypeOperators+    KindSignatures+    ScopedTypeVariables+    FlexibleContexts+    FlexibleInstances+    UndecidableInstances+    RankNTypes+    TypeApplications++library+  import:          common-opts+  hs-source-dirs:  src+  exposed-modules:+    PEG+    PEG.Grammar+    PEG.Indent+    PEG.Member+    PEG.Parse+    PEG.QQ+    PEG.QQ.HsExp+    PEG.Semantics.Simple+    PEG.Syntax+    PEG.TyLevel+    PEG.Type+  build-depends:+      base             >= 4.18 && < 5+    , template-haskell >= 2.19 && < 2.22++test-suite typed-peg-examples+  import:          common-opts+  type:            exitcode-stdio-1.0+  hs-source-dirs:  examples+  main-is:         Main.hs+  other-modules:   Arith, Layout+  build-depends:+      base+    , typed-peg