separate the parser

[fp.git] / src / Lambda / Parser / Fancy.hs

diff --git a/src/Lambda/Parser/Fancy.hs b/src/Lambda/Parser/Fancy.hs
new file mode 100644 (file)
index 0000000..6e87da1
--- /dev/null
+++ b/src/Lambda/Parser/Fancy.hs
@@ -0,0 +1,89 @@
+{-# OPTIONS_GHC
+    -fno-warn-unused-do-bind
+    -fno-warn-orphans
+#-}
+{-# LANGUAGE PatternSynonyms #-}
+
+-- |
+-- Module      :  Lambda.Parser.Fancy
+-- Copyright   :  Tomáš Musil 2014
+-- License     :  BSD-3
+--
+-- Maintainer  :  tomik.musil@gmail.com
+-- Stability   :  experimental
+--
+-- Parser for λ-terms. '.' in λ implies brackets to the end of the context.
+
+-- TODO: proper documentation
+
+module Lambda.Parser.Fancy where
+
+import Data.Text as T hiding (map)
+import Data.Attoparsec.Text
+import Control.Applicative
+
+import Lambda.Term
+
+-- | 
+-- >>> print $ Lambda "x" (Var "x")
+-- (λx.x)
+
+instance Show Term where
+  show (Var x) = x
+  show (EmLambda x y t) = show (Lambda (x ++ " " ++ y) t)
+  show (Lambda x t) = "(λ" ++ x ++ "." ++ show t ++ ")"
+  show (AppApp a b c) = show a ++ " " ++ braced (App b c)
+  show (App t r) = show t ++ " " ++ show r
+
+braced :: Term -> String
+braced t = "(" ++ show t ++ ")"
+
+-- |
+-- prop> t == tRead (show (t :: Term))
+
+tRead :: String -> Term
+tRead s = case parseOnly (parseTerm <* endOfInput) (T.pack s) of
+    (Right t) -> t
+    (Left e) -> error e
+
+parseVar :: Parser Term
+parseVar = do
+  x <- many1 (letter <|> digit)
+  return $! Var x
+
+parseLambda :: Parser Term
+parseLambda = do
+  char '\\' <|> char 'λ'
+  vars <- sepBy1 parseVar (char ' ')
+  char '.'
+  t <- parseTerm
+  return $! createLambda vars t
+
+parseApp :: Parser Term
+parseApp = do
+  aps <- sepBy1 (parseBraces <|> parseLambda <|> parseVar) (char ' ')
+  return $! createApp aps
+
+parseBraces :: Parser Term
+parseBraces = do
+  char '('
+  t <- parseTerm
+  char ')'
+  return t 
+
+parseTerm :: Parser Term
+parseTerm = parseApp <|>
+            parseBraces <|>
+            parseLambda <|>
+            parseVar
+
+createLambda :: [Term] -> Term -> Term
+createLambda (Var x : vs) t = Lambda x $ createLambda vs t
+createLambda [] t = t
+createLambda _ _ = error "createLambda failed"
+
+createApp :: [Term] -> Term
+createApp [t] = t
+createApp (t:ts:tss) = createApp (App t ts : tss)
+createApp [] = error "empty createApp"
+