diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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`). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/examples/Arith.hs b/examples/Arith.hs new file mode 100644 --- /dev/null +++ b/examples/Arith.hs @@ -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") diff --git a/examples/Layout.hs b/examples/Layout.hs new file mode 100644 --- /dev/null +++ b/examples/Layout.hs @@ -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 } diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -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" diff --git a/src/PEG.hs b/src/PEG.hs new file mode 100644 --- /dev/null +++ b/src/PEG.hs @@ -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 diff --git a/src/PEG/Grammar.hs b/src/PEG/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/PEG/Grammar.hs @@ -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 diff --git a/src/PEG/Indent.hs b/src/PEG/Indent.hs new file mode 100644 --- /dev/null +++ b/src/PEG/Indent.hs @@ -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 + } diff --git a/src/PEG/Member.hs b/src/PEG/Member.hs new file mode 100644 --- /dev/null +++ b/src/PEG/Member.hs @@ -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 diff --git a/src/PEG/Parse.hs b/src/PEG/Parse.hs new file mode 100644 --- /dev/null +++ b/src/PEG/Parse.hs @@ -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 diff --git a/src/PEG/QQ.hs b/src/PEG/QQ.hs new file mode 100644 --- /dev/null +++ b/src/PEG/QQ.hs @@ -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 diff --git a/src/PEG/QQ/HsExp.hs b/src/PEG/QQ/HsExp.hs new file mode 100644 --- /dev/null +++ b/src/PEG/QQ/HsExp.hs @@ -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 diff --git a/src/PEG/Semantics/Simple.hs b/src/PEG/Semantics/Simple.hs new file mode 100644 --- /dev/null +++ b/src/PEG/Semantics/Simple.hs @@ -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' diff --git a/src/PEG/Syntax.hs b/src/PEG/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/PEG/Syntax.hs @@ -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 diff --git a/src/PEG/TyLevel.hs b/src/PEG/TyLevel.hs new file mode 100644 --- /dev/null +++ b/src/PEG/TyLevel.hs @@ -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 diff --git a/src/PEG/Type.hs b/src/PEG/Type.hs new file mode 100644 --- /dev/null +++ b/src/PEG/Type.hs @@ -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 diff --git a/typed-peg.cabal b/typed-peg.cabal new file mode 100644 --- /dev/null +++ b/typed-peg.cabal @@ -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