INblobs-0.1.1: src/Functional/Parser.hs

{-|
    Module      :  Functional.Parser
    Copyright   :  (c) Miguel Vilaça 2007

    Maintainer  :  jmvilaca@di.uminho.pt
    Stability   :  experimental
    Portability :  portable


    Small Functional Language: Parser

-}
module Functional.Parser (parse) where

import Functional.Language
import Data.Char


parse :: String -> Either FuncLang String
parse str =
     case filter (nul.snd) res of
	[(term, _)] -> Left term
	_ -> case res of
		[] -> Right "Null result"
		l  -> Right $ "Ambiguous parsing.\n" ++ show l
 where res = reads $ map f str
       f c | isControl c = ' '
	   | otherwise = c
       nul = all (\c -> isControl c || isSpace c)

instance Read FuncLang where
-- readsPrec :: Int -> String -> [(a, String)]
	readsPrec d str =
		map (\(v,s) -> (Var v,s)) (readVar str) -- variables
		++ readParen (d > abst_prec) -- abstraction - allow [x,y]t
                          (\r -> [(vs t, r4) |
				  ("[",r2) <- lex r,
                                  (vs,r3)   <- readVars r2,
                                  (t,r4)   <- readsPrec (abst_prec+1) r3 ]) str
		++ readParen (d > app_prec)
                          (\r -> [(Appl t u, r2) |
                                  (t,r1)   <- readsPrec (app_prec+1) r,
                                  (u,r2)   <- readsPrec (app_prec+1) r1 ]) str
		++ readTerminal TT "tt" str
		++ readTerminal FF "ff" str
		++ readParen (d > iter_prec) -- iterbool
                          (\r -> [(IterBool v f b, r8) |
                                  ("iterbool",r1) <- lex r,
                                  ("(",r2) <- lex r1,
                                  (v,r3)   <- readsPrec 0 r2,
				  (",",r4) <- lex r3,
                                  (f,r5)   <- readsPrec 0 r4,
				  (",",r6) <- lex r5,
                                  (b,r7)   <- readsPrec 0 r6,
				  (")",r8) <- lex r7]) str
		++ readTerminal Zero "0" str
		++ readParen (d > const_prec) -- suc
                          (\r -> [(Succ m, r4) |
                                  ("suc",r1)  <- lex r,
                                  ("(",r2)    <- lex r1,
                                  (m,r3)      <- readsPrec 0 r2,
				  (")",r4)    <- lex r3]) str
		++ readParen (d > iter_prec) -- iternat
                          (\r -> [(IterNat x s z t, r8) |
                                  ("iternat",r1) <- lex r,
                                  ("(",r2) <- lex r1,
                                  (Abst x s,r3)   <- readsPrec 0 r2,
				  (",",r4) <- lex r3,
                                  (z,r5)   <- readsPrec 0 r4,
				  (",",r6) <- lex r5,
                                  (t,r7)   <- readsPrec 0 r6,
				  (")",r8) <- lex r7]) str
		++ readTerminal Nil "nil" str
		++ readParen (d > const_prec) -- cons
                          (\r -> [(Cons a as, r6) |
                                  ("cons(",r1) <- lex r,
                                  ("(",r2)     <- lex r1,
                                  (a,r3)       <- readsPrec 0 r2,
				  (",",r4)     <- lex r3,
                                  (as,r5)      <- readsPrec 0 r4,
				  (")",r6)     <- lex r5]) str
		++ readParen (d > iter_prec) -- iterlist
                          (\r -> [(IterList x y c n l, r8) |
                                  ("iterlist",r1) <- lex r,
                                  ("(",r2) <- lex r1,
                                  (Abst x (Abst y c),r3)   <- readsPrec 0 r2,
				  (",",r4) <- lex r3,
                                  (n,r5)   <- readsPrec 0 r4,
				  (",",r6) <- lex r5,
                                  (l,r7)   <- readsPrec 0 r6,
				  (")",r8) <- lex r7]) str
	 where
	       abst_prec = 5
	       app_prec = 5
	       terminal_prec = 10
	       iter_prec = 10
	       const_prec = 10
	       readTerminal term symb str =
			readParen (d > terminal_prec)
                          (\r -> [(term,t) |
                                  (symb1,t) <- lex r, symb1 == symb]) str
	       readVar str =
			readParen False
                          (\r -> [(v,t) |
                                  (v,t) <- lex r, isVariable v]) str
	       readVars str =
			[ (Abst v, r1)  | (v,r) <- readVar str
					, ("]",r1) <- lex r]
			++
			[ (Abst v . lv, r2)
					| (v,r) <- readVar str
					, (",",r1) <- lex r
					, (lv, r2) <- readVars r1]

reservedWords :: [String]
reservedWords = ["tt","ff","iterbool","0","suc","iternat","nil","cons","iterlist"]

isVariable :: String -> Bool
isVariable str =
	not (null str)
	&& str `notElem` reservedWords
	&& all isAlphaNum str
	&& not (isDigit $ head str)


-- Examples

str = " [x,y,z,a,b]("
	++ "(iterbool(x,y,tt) iterlist([x,y]y (x (a z)), (a z), nil) )"
	++ "(iternat([x]x,x,0) iterbool(y,y,tt)))"

term =  Left $ Abst "x" $ Abst "y" $ Abst "z" $ Abst "a" $ Abst "b" $
     Appl
	(Appl (IterBool x y TT)
		(IterList "x" "y" (Appl y $ Appl x $ Appl a z) (Appl a z) Nil)
	)
	(Appl (IterNat "x" x x Zero)
		(IterBool y y TT)
	)

x = Var "x"
y = Var "y"
z = Var "z"
a = Var "a"