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