src/HM/Parser.hs

   1 {-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-orphans #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3
   4 -- |
   5 -- Module      :  HM.Parser
   6 -- Copyright   :  Tomáš Musil 2014
   7 -- License     :  BSD-3
   8 --
   9 -- Maintainer  :  tomik.musil@gmail.com
  10 -- Stability   :  experimental
  11 --
  12 -- Parser for Hindley-Milner terms and types.
  13
  14 module HM.Parser
  15   ( tRead
  16   , parseTerm
  17   )  where
  18
  19 import Data.Text as T hiding (map)
  20 import Data.Attoparsec.Text
  21 import Control.Applicative
  22
  23 import HM.Term
  24 import qualified Lambda.Parser.Fancy as Lambda
  25 import qualified Lambda.Term as Lambda
  26
  27 braced :: String -> String
  28 braced t = "(" ++ t ++ ")"
  29
  30 instance Show Term where
  31   show (Var x) = x
  32   show (Lam x (NTTerm (Lam y t))) = show (Lam (x ++ " " ++ y) t)
  33   show (Lam x t) = braced $ "λ" ++ x ++ "." ++ show t
  34   show (App a (NTTerm (App b c))) = show a ++ " " ++ (braced $ show (App b c))
  35   show (App t r) = show t ++ " " ++ show r
  36   show (Let x e1 e2) = braced $ "let " ++ x ++ " = " ++ show e1 ++ " in " ++ show e2
  37
  38 instance Show TypedTerm where
  39   show (NTTerm t) = show t
  40   show (TTerm t tp) = braced $ show t ++ " :: " ++ show tp
  41
  42 instance Show Type where
  43   show (Primitive t) = t
  44   show (TypeVar t) = t
  45   show (TypeFunction a b) = braced $ show a ++ " -> " ++ show b
  46
  47 instance Show TypeScheme where
  48   show (TScheme t) = show t
  49   show (TSForAll x t) = braced $ "∀" ++ x ++ ": " ++ show t
  50
  51 tRead :: String -> Term
  52 tRead = undefined
  53
  54 parseTerm :: Parser TypedTerm
  55 parseTerm = parseLet <|>
  56             (lambdaToHM <$> Lambda.parseTerm)
  57
  58 parseLet :: Parser TypedTerm
  59 parseLet = do
  60   char '('
  61   string "let "
  62   (Lambda.Var x) <- Lambda.parseVar
  63   string " = "
  64   e1 <- lambdaToHM <$> Lambda.parseTerm
  65   string " in "
  66   e2 <- lambdaToHM <$> Lambda.parseTerm
  67   char ')'
  68   return . NTTerm $ Let x e1 e2
  69
  70 lambdaToHM :: Lambda.Term -> TypedTerm
  71 lambdaToHM (Lambda.Var x) = NTTerm $ Var x
  72 lambdaToHM (Lambda.App t u) = NTTerm $ App (lambdaToHM t) (lambdaToHM u)
  73 lambdaToHM (Lambda.Lambda x t) = NTTerm $ Lam x (lambdaToHM t)
  74
  75 -- |
  76 -- TODO prop> t == tRead (show (t :: Term))
  77
  78 {-
  79 tRead :: String -> Term
  80 tRead s = case parseOnly (parseTerm <* endOfInput) (T.pack s) of
  81     (Right t) -> t
  82     (Left e) -> error e
  83 -}