peg 0.1 → 0.2
raw patch · 4 files changed
+255/−135 lines, 4 files
Files
Peg.hs view
@@ -14,7 +14,7 @@ You should have received a copy of the GNU General Public License along with peg. If not, see <http://www.gnu.org/licenses/>. -}-{-# LANGUAGE CPP, PatternGuards #-}+{-# LANGUAGE CPP, PatternGuards, DeriveDataTypeable, ScopedTypeVariables #-} #ifdef MAIN module Main where #else@@ -31,7 +31,7 @@ import Text.Parsec.Language (haskellDef) import Data.List import Data.Ord-import System.Console.Haskeline+import System.Console.Haskeline hiding (throwIO, handle) import System.Environment import System.FilePath import System.IO@@ -42,27 +42,22 @@ import qualified Data.Set as S import Data.Map (Map) import qualified Data.Map as M--lexer = P.makeTokenParser haskellDef--integer = P.integer lexer-float = P.float lexer-naturalOrFloat = P.naturalOrFloat lexer-natural = P.natural lexer-whiteSpace = P.whiteSpace lexer-charLiteral = P.charLiteral lexer-stringLiteral = P.stringLiteral lexer+import Control.Exception hiding (try)+import Data.Typeable -probe s x = trace (s ++ show x) x+-------------------- Data Types -------------------- type Stack = [Value]+type Env = Map String (Peg ()) data PegState = PegState { psStack :: Stack, psArgStack :: Stack,- psWords :: Map String (Peg ()),+ psWords :: Env, psAvoid :: Set Stack }-type Peg = StateT PegState (LogicT (Either Stack))+type Peg = StateT PegState (LogicT IO)+data PegException = PegException Stack Stack deriving (Show, Typeable)+instance Exception PegException data Rule = Rule { getRule :: Stack -> Peg Stack }-data Value = F Double | I Integer | C Char | L Stack | W String deriving (Show, Eq, Ord)+data Value = F Double | I Integer | C Char | L Stack | W String | Io deriving (Show, Eq, Ord) isWord (W _) = True isWord _ = False@@ -91,9 +86,20 @@ isString = isJust . toString -up :: Stack -> Peg ()-up = lift . lift . Left+isIo Io = True+isIo _ = False +-------------------- Debug --------------------++probe s x = trace (s ++ show x) x++traceStack :: Peg ()+traceStack = do+ s <- psStack <$> get+ trace (showStack s) $ return ()++-------------------- Peg Monad Operations --------------------+ -- | pop an argument from the stack, push onto argument stack getArg' check st = do force@@ -105,7 +111,7 @@ if check x then return () else if st x- then pushArg x >> done+ then pushStack x >> done else mzero pushArg x @@ -114,6 +120,7 @@ pushStack x = modify (\(PegState s a m xx) -> PegState (x:s) a m xx) appendStack x = modify (\(PegState s a m xx) -> PegState (x++s) a m xx)+ popStack :: Peg Value popStack = do PegState (x:s) a m xx <- get put $ PegState s a m xx@@ -123,7 +130,7 @@ -- | can't go any further, bail done = do st <- get- up $ reverse (psArgStack st) ++ psStack st+ liftIO . throwIO $ PegException (psStack st) (psArgStack st) pushArg x = modify (\(PegState s a m xx) -> PegState s (x:a) m xx) popArg = do PegState s (x:a) m xx <- get@@ -142,12 +149,7 @@ (W w : _) -> popStack >> doWord w -- >> traceStack _ -> return () -traceStack :: Peg ()-traceStack = do- s <- psStack <$> get- trace (showStack s) $ return ()--wordMap = foldl' (flip (uncurry $ M.insertWith mplus)) M.empty+-------------------- Converters -------------------- op2i f = do getArgNS isInt@@ -168,6 +170,11 @@ F x <- popArg pushStack . F . f $ x +opfi f = do+ getArg isFloat+ F x <- popArg+ pushStack . I . f $ x+ reli f = do getArgNS isInt getArgNS isInt@@ -194,16 +201,42 @@ getArg anything pushStack . W . show . f =<< popArg +-------------------- Helpers for builtins --------------------++(f ||. g) x = f x || g x+(f &&. g) x = f x && g x+ anything (W "]") = False anything (W "[") = False anything _ = True -brac (W "]") = True-brac _ = False+unpackList = do+ getArg (isList ||. (== W "]"))+ x <- popArg+ case x of+ W "]" -> return ()+ L l -> do pushStack $ W "["+ appendStack l -(f ||. g) x = f x || g x-(f &&. g) x = f x && g x+bind n l = modify $ \(PegState s a w xx) -> PegState s a (M.insertWith interleave n (f l) w) xx+ where f l = do force+ w <- popArg+ force >> appendStack l >> force+ pushArg w +unbind n = modify $ \(PegState s a w xx) -> PegState s a (M.delete n w) xx++gatherList n l (w@(W "]") : s) = gatherList (n+1) (w:l) s+gatherList n l (w@(W "[") : s)+ | n <= 0 = Right (l,s)+ | otherwise = gatherList (n-1) (w:l) s+gatherList n l (w:s) = gatherList n (w:l) s+gatherList n l [] = Left l++wordMap = foldl' (flip (uncurry $ M.insertWith mplus)) M.empty++-------------------- Built-ins --------------------+ builtins = wordMap [ ("+", op2i (+)), ("-", op2i (-)),@@ -274,7 +307,7 @@ put $ PegState s' a w xx pushStack . L . reverse $ l), ("pushr", do getArg anything- getArg (isList ||. brac)+ getArg (isList ||. (== W "]")) x <- popArg case x of -- toss it over the fence@@ -282,53 +315,32 @@ pushStack (W "]") L l -> do x <- popArg pushStack $ L (x:l)),- ("popr", do getArg (isList ||. brac)+ ("popr", do unpackList+ -- reach across the fence+ pushArg $ W "]"+ getArg (anything ||. (== W "[")) x <- popArg- case x of- -- reach across the fence- W "]" -> do pushArg (W "]")- getArg (anything ||. (== W "["))- x <- popArg- popArg- guard $ x /= W "["- pushStack (W "]")- pushStack x- -- unpack the list and force it- L l -> do pushStack $ W "["- pushArg $ W "]"- appendStack l- getArg (anything ||. (== W "["))- x <- popArg- guard $ x /= W "["- popArg >>= pushStack- pushStack x- _ -> mzero),+ guard $ x /= W "["+ popArg >>= pushStack+ pushStack x),+ ("dupnull?", do unpackList+ -- take a peek across the fence+ pushArg $ W "]"+ getArg (anything ||. (== W "["))+ x <- popArg+ pushStack x+ popArg >>= pushStack+ pushStack . W . show $ x == W "["), (".", do getArg isList- getArg (isList ||. brac)+ getArg (isList ||. (== W "]")) x <- popArg case x of -- remove the fence W "]" -> do L l <- popArg- pushArg $ W "]" appendStack l- popArg >>= pushStack+ pushStack $ W "]" L x -> do L y <- popArg pushStack . L $ y ++ x),- ("dupnull?", do getArg (isList ||. brac)- x <- popArg- case x of- -- take a peek across the fence- W "]" -> do pushArg $ W "]"- force- y <- peekStack- popArg >>= pushStack- pushStack . W . show $ y == W "["- L l -> do pushStack $ W "["- appendStack l- force- x <- peekStack- pushStack $ W "]"- pushStack . W . show $ x == W "["), ("assert", getArgNS (== W "True") >> popArg >> force), ("deny", getArgNS (== W "False") >> popArg >> force), ("\\/", do getArg anything@@ -342,6 +354,7 @@ ("list?", is_type isList), ("char?", is_type isChar), ("string?", is_type isString),+ ("io?", is_type isIo), ("eq?", do getArg anything getArg anything x <- popArg@@ -358,8 +371,10 @@ unbind s), ("$", do getArg isList L l <- popArg+ w <- popArg -- temporarily remove $ from the arg stack appendStack l- force),+ force+ pushArg w), ("seq", do getArg anything force pushStack =<< popArg),@@ -370,33 +385,51 @@ Just s <- toString <$> popArg let Right x = parseStack s appendStack x- force)]-{--runIO (L [W "IO", L (W op : args), L k] : s) =- case (op, args) of- ("getChar", []) -> getChar >>= runIO . (++s) . (:k) . C- ("putChar", [C c]) -> putChar c >> runIO (k ++ s)- ("return", [x]) -> runIO (x : k ++ s)--}-bind n l = modify $ \(PegState s a w xx) -> PegState s a (M.insertWith interleave n (f l) w) xx- where f l = do force- w <- popArg- force >> appendStack l >> force- pushArg w--unbind n = modify $ \(PegState s a w xx) -> PegState s a (M.delete n w) xx+ force),+ ("realToFrac", do getArg (isInt ||. isFloat)+ a <- popArg+ case a of+ I x -> pushStack . F . realToFrac $ x+ F x -> pushStack a),+ ("round", opfi round),+ ("floor", opfi floor),+ ("ceiling", opfi ceiling),+ ("getChar", do getArg isIo+ pushStack =<< popArg+ liftIO getChar >>= pushStack . C),+ ("putChar", do getArg isChar+ getArg isIo+ io <- popArg+ C c <- popArg+ liftIO $ putChar c+ pushStack io),+ ("getLine", do getArg isIo+ pushStack =<< popArg+ liftIO getLine >>= pushStack . L . map C),+ ("putStr", do getArg isString+ getArg isIo+ io <- popArg+ Just s <- toString <$> popArg+ liftIO $ putStr s+ pushStack io),+ ("putStrLn", do getArg isString+ getArg isIo+ io <- popArg+ Just s <- toString <$> popArg+ liftIO $ putStrLn s+ pushStack io)] -peekStack = do- (x:_) <- psStack <$> get- return x+-------------------- Parsing -------------------- -gatherList n l (w@(W "]") : s) = gatherList (n+1) (w:l) s-gatherList n l (w@(W "[") : s)- | n <= 0 = Right (l,s)- | otherwise = gatherList (n-1) (w:l) s-gatherList n l (w:s) = gatherList n (w:l) s-gatherList n l [] = Left l+lexer = P.makeTokenParser haskellDef +integer = P.integer lexer+float = P.float lexer+naturalOrFloat = P.naturalOrFloat lexer+natural = P.natural lexer+whiteSpace = P.whiteSpace lexer+charLiteral = P.charLiteral lexer+stringLiteral = P.stringLiteral lexer word :: Parser String word = (:) <$> (letter <|> oneOf ":_?") <*> many (alphaNum <|> oneOf "?_'#")@@ -406,8 +439,6 @@ fmap (:[]) (oneOf "[]{};") <|> (string "-") ---list = char '[' >> stackExpr <* char ']'- number = do m <- optionMaybe (char '-') let f = maybe (either I F) (const $ either (I . negate) (F . negate)) m@@ -436,6 +467,7 @@ loop (C x : s) = loop s . (' ':) . shows x loop (F x : s) = loop s . (' ':) . shows x loop (W x : s) = loop s . ((' ':x) ++)+ loop (Io : s) = loop s . (" IO" ++) loop (L [] : s) = loop s . (" [ ]" ++) loop (L x : s) = case toString (L x) of Just str -> loop s . (' ':) . shows str@@ -443,13 +475,11 @@ parseStack = parse stackExpr "" -evalStack' fs m src = do- s <- fs <$> parseStack src- return . observeManyT 8 $ do- PegState s _ m _ <- execStateT force $ PegState s [] m S.empty- return (s, m)+-------------------- Main -------------------- -evalStack fs m = fmap (either (\s -> [(s, m)]) id) . evalStack' fs m+evalStack (s, m) = observeManyT 8 $ do+ PegState s _ m _ <- execStateT force $ PegState s [] m S.empty+ return (s, m) hGetLines h = do e <- hIsEOF h@@ -464,37 +494,48 @@ let files = filter ((==".peg").takeExtension) args m <- foldM (\m f -> do l <- getLinesFromFile f- case load [] m l of- Left e -> print e >> return m- Right m' -> return m') builtins files- runInputT defaultSettings (evalLoop True [] m)+ load [] m l) builtins files+ runInputT defaultSettings $ evalLoop (Right []) m load :: Stack- -> Map String (Peg ())+ -> Env -> [String]- -> Either ParseError (Map String (Peg ()))-load s m [] = Right m+ -> IO Env+load s m [] = return m load s m (input:r) =- case head <$> evalStack (++s) m input of- Left e -> Left e- Right (s', m') -> load s' m' r+ case parseStack input of+ Left e -> print e >> return m+ Right s -> handle (\(_ :: PegException) -> load s m r) $ do+ (s', m') : _ <- evalStack (s, m)+ load s' m' r -ifNotNull f [] = []-ifNotNull f x = f x+-- I/O ideas+-- I/O token: dup I/O --> spawn thread, pop I/O --> kill thread+-- x0 x1 x2 IO x3 x4 IO x5+-- | main thread | thread 0 | thread 1 ...+-- .. IO [ x ] dip+-- <------|+-- send to thread n-1 -evalLoop :: Bool -> Stack -> Map String (Peg ()) -> InputT IO ()-evalLoop n s m = do- minput <- getInputLineWithInitial ": " .- (if n then (flip (,) "" . ifNotNull (++" "))- else ((,) "") . (" "++)) $ showStack s+makeIOReal = map (\x -> if x == W "IO" then Io else x)++evalLoop :: Either (Stack, Stack) Stack -> Env -> InputT IO ()+evalLoop p m = do+ let text = case p of+ Left (s, a) -> (showStack s, ' ' : showStack (reverse a))+ Right [] -> ("", "")+ Right s -> (showStack s ++ " ", "")+ minput <- getInputLineWithInitial ": " text case minput of Nothing -> return () Just "" -> return ()- Just input -> case evalStack' id m input of- Left e -> outputStrLn (show e) >> evalLoop n s m- Right x -> case x of- Left s' -> evalLoop False s' m- Right [] -> evalLoop n [W "no"] m- Right ((s',m'):r) -> do- mapM_ (outputStrLn . showStack . fst) r- evalLoop True s' m'+ Just input -> case parseStack input of+ Left e -> outputStrLn (show e) >> evalLoop p m+ Right s -> do+ x' <- liftIO . handle (\(PegException s a) -> return (Left (s, a))) $ Right <$> evalStack (makeIOReal s, m)+ case x' of+ Left s' -> evalLoop (Left s') m+ Right [] -> evalLoop (Right [W "no"]) m+ Right ((s',m'):r) -> do+ mapM_ (outputStrLn . showStack . fst) r+ evalLoop (Right s') m'
README.md view
@@ -4,16 +4,22 @@ Overview -------- -Peg is a lazy non-deterministic concatenative programming language.+Peg is a lazy non-deterministic concatenative programming language inspired by Haskell, Joy, and Prolog. In contrast to most concatenative programming languages, Peg starts evaluation from the right, evaluating arguments to the left as needed. -For example, even though the word 'no' can never be resolved:+For example, even though the word `no` can never be resolved: no 1 2 + --> no 3 This is because `+` requires only two arguments on the stack. +Another demonstration of laziness:++ 0 [1+] iterate++This creates the infinite stack `.. 3 2 1 0`. Try `pop`ing a few times to see how it works.+ Branching is accomplished with the choice operator `\/`. Both paths are followed non-deterministically. Paths are terminated when a word cannot be resolved. Multiple definitions for a word cause the definitions to be substituted non-deterministically. This allows words (even built-in words) to be extended for new types.@@ -30,6 +36,11 @@ [1 2 3 +] popr --> [1] 5 +A string literal is a stack consisting only of characters. They are read and displayed backwards from stacks, to make them readable.++ ['o' 'l' 'l' 'e' 'h'] --> "hello"+ "hello" 0 pushr --> ['o' 'l' 'l' 'e' 'h' 0]+ Peg is flat, in that any expression can be divided on white space (except inside a literal), the pieces evaluated independently, and when the results are concatenated, evaluate to an equivalent expression to the original expression. Example:@@ -39,7 +50,11 @@ ] popr --> ] popr [ 3 ] popr --> [ ] 3 -Built-in words+Instead of using a monad to implement pure functional I/O, Peg simply uses a token representing the state of the world, `IO`. Words that perform I/O must require `IO` as an argument. If the word does not put it back, it will destroy the world.++`IO` can only be introduced from the top-level, by typing `IO`. In other places, such as definitions and `read`, `IO` is parsed as a word with no special meaning.++Built-in Words -------------- The format below is:@@ -68,7 +83,7 @@ `False` `deny` --> -- opposite of assert -`x` `y` `\/` --> 'x' \/ 'y' -- continues execution non-deterministically with `x` and `y`+`x` `y` `\/` --> `x` \/ `y` -- continues execution non-deterministically with `x` and `y` `int?`, `float?`, `word?`, `list?`, `char?`, `string?` -- test type of argument, returning `True` or `False` @@ -86,8 +101,26 @@ `"x"` `read` --> `x` -- convert string representation of `x` into `x`, opposite of `show` -`+`, `-`, `*`, `div`, `^`, `^^`, `**`, `exp`, `sqrt`, `log`, `logBase`, `sin`, `tan`, `cos`, `asin`, `atan`, `acos`, `sinh`, `tanh`, `cosh`, `asinh`, `atanh`, `acosh`, `<`, `<=`, `>`, `>=` -- numeric and comparison words defined as in Haskell Prelude+`+`, `-`, `*`, `div`, `^`, `^^`, `**`, `exp`, `sqrt`, `log`, `logBase`, `sin`, `tan`, `cos`, `asin`, `atan`, `acos`, `sinh`, `tanh`, `cosh`, `asinh`, `atanh`, `acosh`, `<`, `<=`, `>`, `>=`, `realToFrac`, `round`, `floor`, `ceiling` -- numeric and comparison words defined as in Haskell Prelude +`getChar`, `putChar`, `getLine`, `putStr`, `putStrLn` -- similar to Haskell Prelude. Instead of running in IO monad, they require `IO` as the first argument, putting it back after executing++A simple IO example:++ IO "What's your name?" putStrLn getLine "!" "Hello " splice putStrLn++Peg supports a curly bracket notation to allow for case statements and do-notation. Curly braces trivially reduce to a nested stack.++`{` --> `[` `[`++`;` --> `]` `[`++`}` --> `]` `]`++Usage with `case`:++ b {1 a; 2 b} case --> 2+ Library: lib.peg ---------------- @@ -95,4 +128,42 @@ `foldr` and `foldl` are swapped from the Haskell definitions, because "lists" are stacks, and elements are added to the right side of a stack. Similarly for `scanr` and `scanl`. -Most of the Haskell Prelude is implemented, except words that aren't very useful or are replaced by a built-in word. I'm still working on IO.+Most of the Haskell Prelude is implemented, except words that aren't very useful or are replaced by a built-in word.++Running the Peg Interpreter+---------------------------++Build the interpreter using Cabal (cabal configure; cabal build)++Just call the `peg` executable with source files to be loaded (such as lib.peg) as arguments.++The interpreter evaluates the input after pressing `Enter`. The results will be printed after the next prompt, allowing you to edit the results. If the cursor is not on the right, a word did not have enough arguments to be evaluated; the cursor will be placed so that you can provide the missing arguments. If there are multiple results, up to 8 results will be printed, but only the first will appear at the prompt. If there are no results, the result `no` is shown, which is equivalent (defined in `lib.peg`).++[Haskeline](http://hackage.haskell.org/package/haskeline) provides the line editing interface. Clearing the input and pressing `Enter` will exit the interpreter.++Future+------++### I/O++I have tried modeling I/O after Haskell's monad approach, but monads seem to be better suited to applicative languages, despite being possible in a concatenative language.++I have implemented a different method of performing I/O in a pure functional way, as described above (I/O words require an `IO` token.) This may allow more flexible use of I/O than a monad; threads could be spawned with `IO dup` and ended with `IO pop`. Also, more complex operations may be possible, requiring multiple `IO`s.++### Type System++The current idea is to use explicit type checks (such as `int?`) instead of introducing a different syntax for type annotations. This would allow the type system to be extended using the base language, and support dependent typing. It would also allow optional run time typing.++The interpreter is currently dynamically typed, but I would like to make the compiler support static type checking, by proving that the result of a computation cannot be `no`. The compiler could also optimize away types and most non-determinism. I do realize that, in general, static type checking will be undecidable. The compiler will be designed to resolve undecidable types interactively with the user.++The language would not change significantly. Product types are built from stacks, such as `[1 2 Ratio]`, and sum types are created using `\/`, such as `[1 Left] \/ ['a' Right]`, using undefined words at the top of the stack as tags. Constructors can be created as the matching lowercase word, such as `x left --> [x Left]`. Using the same word as the tag results in an infinitely nested stack, so the values can never be retrieved.++I have done some work on types in `types.peg`, which extends some words to operate on type tags.++### Modules++I will need to add a module system to allow encapsulation.++### Compiler++The compiler will first target C, to allow easy portability. I am interested in running Peg code in embedded systems, especially because it is difficult to use other high-level languages such as Haskell on most microcontrollers.
lib.peg view
@@ -192,7 +192,7 @@ [[not] . span] "break" :def -- ( a a enumFromTo -> [A] )-[?over - 1+ swap [[1+] iterate] pushl swap take] "enumFromTo" :def+[over - 1+ swap [[1+] iterate] pushl swap take] "enumFromTo" :def -- ( [A] length -> Int ) [0 length'] "length" :def@@ -362,3 +362,11 @@ --[[return] pushl singleton [[]] [IO] splice] "return" :def --[swap popr {popr [head swap . [>>=] .] dip [IO] pushl pushl : IO} case] ">>=" :def ++-- I/O++-- ( IO a print --> IO ) -- prints representation of a to stdout+[show putStrLn] "print" :def++-- ( IO readLn --> IO a ) -- parses input from stdin to a+[getLine read] "readLn" :def
peg.cabal view
@@ -6,7 +6,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.1+Version: 0.2 -- A short (one-line) description of the package. Synopsis: a lazy non-deterministic concatenative programming language