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   , parseTypedTerm
  17   , parseVar
  18   )  where
  19
  20 import Data.Char (isAsciiLower, isAsciiUpper)
  21 import Data.Text as T hiding (map)
  22 import Data.Attoparsec.Text
  23 import Control.Applicative
  24
  25 import HM.Term
  26
  27 -- $setup
  28 -- >>> import Test.QuickCheck
  29 -- >>> import Test.HM.Term
  30
  31 -- |
  32 -- >>> print $ Lam "x" (Var "x")
  33 -- (λx.x)
  34
  35
  36
  37 braced :: String -> String
  38 braced t = "(" ++ t ++ ")"
  39
  40 instance Show Term where
  41   show (Var x) = x
  42   show (Lam x (NTTerm (Lam y t))) = show (Lam (x ++ " " ++ y) t)
  43   show (Lam x t) = braced $ "λ" ++ x ++ "." ++ show t
  44   show (App a (NTTerm (App b c))) = show a ++ " " ++ braced ( show (App b c))
  45   show (App t r) = show t ++ " " ++ show r
  46   show (Let x e1 e2) = braced $ "LET " ++ x ++ " = " ++ show e1 ++ " IN " ++ show e2
  47   show (Lit (LInt x)) = show x
  48   show (Lit (LBool x)) = show x
  49   show (Lit (LFunc x)) = show x
  50
  51 instance Show TypedTerm where
  52   show (NTTerm t) = show t
  53   show (TTerm (Var x) tp) = x ++ " :: " ++ show tp
  54   show (TTerm t tp) = braced (show t) ++ " :: " ++ show tp
  55
  56 instance Show Type where
  57   show (Primitive t) = t
  58   show (TypeVar t) = t
  59   show (TypeFunction a b) = braced $ show a ++ " -> " ++ show b
  60
  61 instance Show TypeScheme where
  62   show (TScheme t) = show t
  63   show (TSForAll x t) = braced $ "∀" ++ x ++ ": " ++ show t
  64
  65 tRead :: String -> TypedTerm
  66 tRead s = case parseOnly (parseTypedTerm <* endOfInput) (T.pack s) of
  67     (Right t) -> t
  68     (Left e) -> error e
  69
  70 parseTerm :: Parser Term
  71 parseTerm = parseLet <|>
  72             parseLambda <|>
  73             parseApp <|>
  74             parseBraces parseTerm <|>
  75             parseLit <|>
  76             parseVar
  77
  78 parseTermNoApp :: Parser Term
  79 parseTermNoApp = parseBraces parseTerm <|>
  80             parseLet <|>
  81             parseVar <|>
  82             parseLit <|>
  83             parseLambda
  84
  85 parseTypeAndTerm :: Parser Term -> Parser TypedTerm
  86 parseTypeAndTerm p = do
  87   term <- p
  88   string " :: "
  89   tp <- parseTypeScheme
  90   return $! TTerm term tp
  91
  92
  93 parseTypedTermNoApp :: Parser TypedTerm
  94 parseTypedTermNoApp = parseBraces parseTypedTerm <|>
  95                       parseTypeAndTerm parseTermNoApp <|>
  96                       (NTTerm <$> parseTermNoApp)
  97
  98 parseTypedTerm :: Parser TypedTerm
  99 parseTypedTerm = parseTypeAndTerm parseTerm <|>
 100                  (NTTerm <$> parseTerm) <|>
 101                  parseBraces parseTypedTerm
 102
 103 parseType :: Parser Type
 104 parseType = parseType <|>
 105             parseTypeFunction <|>
 106             parsePrimitive <|>
 107             parseTypeVar
 108
 109 parsePrimitive :: Parser Type
 110 parsePrimitive = do
 111   x <- satisfy isAsciiUpper
 112   xs <- many letter
 113   return $! Primitive (x:xs)
 114
 115 parseTypeVar :: Parser Type
 116 parseTypeVar = do
 117   x <- many1 $ satisfy isAsciiLower
 118   return $! TypeVar x
 119
 120 parseTypeFunction :: Parser Type
 121 parseTypeFunction = do
 122   a <- parseBraces parseType <|> parsePrimitive <|> parseTypeVar
 123   string " -> "
 124   b <- parseType
 125   return $! TypeFunction a b
 126
 127 parseTypeScheme :: Parser TypeScheme
 128 parseTypeScheme = parseBraces parseTypeScheme <|>
 129                   parseForAll <|>
 130                   (TScheme <$> parseType)
 131
 132 parseForAll :: Parser TypeScheme
 133 parseForAll = do
 134   string "FORALL "
 135   (TypeVar x) <- parseTypeVar
 136   string ": "
 137   t <- parseTypeScheme
 138   return $! TSForAll x t
 139
 140 parseBraces :: Parser a -> Parser a
 141 parseBraces p = do
 142   char '('
 143   t <- p
 144   char ')'
 145   return t
 146
 147 parseLet :: Parser Term
 148 parseLet = do
 149   string "LET "
 150   (Var x) <- parseVar
 151   string " = "
 152   e1 <- parseTypedTerm
 153   string " IN "
 154   e2 <- parseTypedTerm
 155   return $! Let x e1 e2
 156
 157 parseVar :: Parser Term
 158 parseVar = do
 159   x <- many1 $ satisfy isAsciiLower
 160   return $! Var x
 161
 162 parseLit :: Parser Term
 163 parseLit = do
 164   x <- parseLInt <|> parseLBool <|> parseLFun
 165   return $! Lit x
 166
 167 parseLFun :: Parser Literal
 168 parseLFun =
 169   (string "If" >> return (LFunc If))
 170
 171 parseLBool :: Parser Literal
 172 parseLBool =
 173   (string "True" >> return (LBool True)) <|>
 174   (string "False" >> return (LBool False))
 175
 176 parseLInt :: Parser Literal
 177 parseLInt = do
 178   x <- decimal
 179   return $! LInt x
 180
 181 parseLambda :: Parser Term
 182 parseLambda = do
 183   char '\\' <|> char 'λ' <|> char 'L'
 184   vars <- sepBy1 parseVar (char ' ')
 185   char '.'
 186   t <- parseTypedTerm
 187   let (NTTerm l) = createLambda vars t
 188   return $! l
 189
 190 parseApp :: Parser Term
 191 parseApp = do
 192   aps <- sepBy1 parseTypedTermNoApp (char ' ')
 193   createApp aps
 194
 195 createLambda :: [Term] -> TypedTerm -> TypedTerm
 196 createLambda (Var x : vs) t = NTTerm . Lam x $ createLambda vs t
 197 createLambda [] t = t
 198 createLambda _ _ = error "createLambda failed"
 199
 200 createApp :: [TypedTerm] -> Parser Term
 201 createApp [t,ts] = return $ App t ts
 202 createApp (t:ts:tss) = createApp (NTTerm (App t ts) : tss)
 203 createApp _ = fail "not App"
 204
 205
 206 -- |
 207 -- TODO prop> t == tRead (show (t :: Term))