more work on Hindley-Milner

[fp.git] / src / HM / Parser.hs

diff --git a/src/HM/Parser.hs b/src/HM/Parser.hs
new file mode 100644 (file)
index 0000000..556cbdb
--- /dev/null
+++ b/src/HM/Parser.hs
@@ -0,0 +1,83 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module      :  HM.Parser
+-- Copyright   :  Tomáš Musil 2014
+-- License     :  BSD-3
+--
+-- Maintainer  :  tomik.musil@gmail.com
+-- Stability   :  experimental
+--
+-- Parser for Hindley-Milner terms and types.
+
+module HM.Parser 
+  ( tRead
+  , parseTerm
+  )  where
+
+import Data.Text as T hiding (map)
+import Data.Attoparsec.Text
+import Control.Applicative
+
+import HM.Term
+import qualified Lambda.Parser.Fancy as Lambda
+import qualified Lambda.Term as Lambda
+
+braced :: String -> String
+braced t = "(" ++ t ++ ")"
+
+instance Show Term where
+  show (Var x) = x
+  show (Lam x (NTTerm (Lam y t))) = show (Lam (x ++ " " ++ y) t)
+  show (Lam x t) = braced $ "λ" ++ x ++ "." ++ show t 
+  show (App a (NTTerm (App b c))) = show a ++ " " ++ (braced $ show (App b c))
+  show (App t r) = show t ++ " " ++ show r
+  show (Let x e1 e2) = braced $ "let " ++ x ++ " = " ++ show e1 ++ " in " ++ show e2 
+
+instance Show TypedTerm where
+  show (NTTerm t) = show t
+  show (TTerm t tp) = braced $ show t ++ " :: " ++ show tp 
+
+instance Show Type where
+  show (Primitive t) = t
+  show (TypeVar t) = t
+  show (TypeFunction a b) = braced $ show a ++ " -> " ++ show b 
+  
+instance Show TypeScheme where
+  show (TScheme t) = show t
+  show (TSForAll x t) = braced $ "∀" ++ x ++ ": " ++ show t
+
+tRead :: String -> Term
+tRead = undefined
+
+parseTerm :: Parser TypedTerm
+parseTerm = parseLet <|>
+            (lambdaToHM <$> Lambda.parseTerm)
+
+parseLet :: Parser TypedTerm
+parseLet = do
+  char '('
+  string "let "
+  (Lambda.Var x) <- Lambda.parseVar
+  string " = "
+  e1 <- lambdaToHM <$> Lambda.parseTerm
+  string " in "
+  e2 <- lambdaToHM <$> Lambda.parseTerm
+  char ')'
+  return . NTTerm $ Let x e1 e2
+
+lambdaToHM :: Lambda.Term -> TypedTerm
+lambdaToHM (Lambda.Var x) = NTTerm $ Var x
+lambdaToHM (Lambda.App t u) = NTTerm $ App (lambdaToHM t) (lambdaToHM u)
+lambdaToHM (Lambda.Lambda x t) = NTTerm $ Lam x (lambdaToHM t)
+
+-- |
+-- TODO 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
+-}