datatype/Language/Quote.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 {-# LANGUAGE QuasiQuotes #-}
   3 {-# LANGUAGE TupleSections #-}
   4 {-# LANGUAGE ParallelListComp #-}
   5 module Language.Quote where
   6
   7 import Data.Char
   8 import Data.List
   9 import Debug.Trace
  10
  11 import Control.Applicative
  12 import Control.Monad
  13 import Language.Haskell.TH.Syntax
  14 import Language.Haskell.TH.Quote
  15 import Language.Haskell.TH
  16
  17 import Language
  18 import Language.GenDSL
  19
  20 cp :: QuasiQuoter
  21 cp = QuasiQuoter
  22     { quoteExp = quoteCPExp
  23     , quotePat = undefined
  24     , quoteType = undefined
  25     , quoteDec = undefined
  26     }
  27
  28 appFst f (a, b) = (f a, b)
  29
  30 newtype Parser t a = Parser {runParser :: [t] -> Maybe (a, [t])}
  31 instance Functor (Parser t) where
  32     fmap f m = Parser $ fmap (appFst f) . runParser m
  33 instance Applicative (Parser t) where
  34     pure a = Parser $ Just . (a,)
  35     l <*> r = Parser $ \ts->runParser l ts >>= \(a, ts')->runParser r ts' >>= \(b, ts'')->pure (a b, ts'')
  36 instance Monad (Parser t) where
  37     ma >>= a2mb = Parser $ \ts->runParser ma ts >>= \(a, ts')->runParser (a2mb a) ts'
  38 instance Alternative (Parser t) where
  39     empty = Parser $ \_->Nothing
  40     l <|> r = Parser $ \ts->runParser l ts <|> runParser r ts
  41
  42 pTop :: Parser t t
  43 pTop = Parser uncons
  44
  45 pFail :: Parser t a
  46 pFail = Parser $ \_->Nothing
  47
  48 pSatisfy :: (t -> Bool) -> Parser t t
  49 pSatisfy pred = pTop >>= \v->if pred v then pure v else pFail
  50
  51 pToken :: Eq t => t -> Parser t t
  52 pToken t = pSatisfy (t==)
  53
  54 pChainl :: Parser t (a -> a -> a) -> Parser t a -> Parser t a
  55 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
  56
  57 pChainr :: Parser t (a -> a -> a) -> Parser t a -> Parser t a
  58 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
  59
  60 pNonfix :: Parser t (a -> a -> a) -> Parser t a -> Parser t a
  61 pNonfix op p = (\l op r->l `op` r) <$> p <*> op <*> p <|> p
  62
  63 pSepBy :: Parser t s -> Parser t a -> Parser t [a]
  64 pSepBy sep el = (:) <$> el <*> many (sep *> el) <|> pure []
  65
  66 pBrack :: Parser String s -> Parser String s
  67 pBrack p = pToken "(" *> p <* pToken ")"
  68
  69 pCase :: Parser String Exp
  70 pCase = mkCase <$ pToken "case" <*> pExp <* pToken "of" <*> some pCaseMatch
  71   where
  72     mkCase :: Exp -> [(Pat, Exp)] -> Exp
  73     mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
  74       where
  75         mkCaseMatch :: Pat -> Exp -> Exp -> Exp
  76         mkCaseMatch (VarP v) e _ = LetE [FunD v [Clause [] (NormalB name) []]] e
  77         mkCaseMatch WildP e _ = e
  78         mkCaseMatch (ConP consName fields) e rest
  79             =      VarE (mkName "if'")
  80             `AppE` (VarE (mkName $ "is" ++ stringName consName) `AppE` name) --Predicate
  81             `AppE` LetE [mkFieldMatch idx f | f <- fields | idx <- [0..]] e
  82             `AppE` rest
  83           where
  84             mkFieldMatch idx (VarP v) = FunD v [Clause [] (NormalB $ VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` name) []]
  85
  86 pCaseMatch :: Parser String (Pat, Exp)
  87 pCaseMatch = (,) <$> pPat <* pToken "->" <*> pExp
  88
  89 pExp :: Parser String Exp
  90 pExp
  91     = foldr ($) (pChainl (pure AppE) pBasic)
  92     [ pChainr $ parseOps ["^."]
  93     , pChainl $ parseOps ["*.", "/."]
  94     , pChainl $ parseOps ["+.", "-."]
  95     , pNonfix $ parseOps ["==.", "/=.", "<.", ">.", "<=.", ">=."]
  96     , pChainr $ parseOps ["&."]
  97     , pChainr $ parseOps ["|."]
  98     ]
  99   where
 100     parseOps = foldr1 (<|>) . map (\op->ifx op <$ pToken op)
 101
 102     pBasic :: Parser String Exp
 103     pBasic
 104         =   VarE <$> pVar
 105         <|> AppE (VarE (mkName "lit")) . LitE <$> pLit
 106         <|> pBrack pExp
 107
 108 pLit :: Parser String Lit
 109 pLit
 110 --    =   CharL <$ pToken '\'' <*> pTop <* pToken '\''
 111     = (IntegerL . read) <$> pSatisfy (all isDigit)
 112
 113 pVar :: Parser String Name
 114 pVar = mkName <$> pSatisfy (\x->isLower (head x) && all isAlpha x && Prelude.not (x `elem` kw))
 115
 116 pCon :: Parser String Name
 117 pCon = mkName <$> pSatisfy (\x->isUpper (head x) && all isAlpha x && Prelude.not (x `elem` kw))
 118
 119 kw = ["case", "of"]
 120
 121 pPat :: Parser String Pat
 122 pPat
 123     =   ConP <$> pCon <*> many pPat
 124     <|> VarP <$> pVar
 125     <|> WildP <$ pToken "_"
 126
 127 parseCP (file, line, col) s =
 128     case runParser pCase (let ts = lexer s in trace (show ts) ts) of
 129         Nothing -> fail "Parsing failed"
 130         Just (_, _:_) -> fail "Non-exhaustive parse found"
 131         Just (e, []) -> pure e
 132
 133 lexer :: [Char] -> [String]
 134 lexer ('c':'a':'s':'e':rest) = "case":lexer rest
 135 lexer ('o':'f':rest) = "of":lexer rest
 136 lexer ('-':'>':rest) = "->":lexer rest
 137 lexer ('^':'.':rest) = "^.":lexer rest
 138 lexer ('*':'.':rest) = "*.":lexer rest
 139 lexer ('/':'.':rest) = "/.":lexer rest
 140 lexer ('+':'.':rest) = "+.":lexer rest
 141 lexer ('-':'.':rest) = "-.":lexer rest
 142 lexer ('|':'.':rest) = "|.":lexer rest
 143 lexer ('&':'.':rest) = "&.":lexer rest
 144 lexer ('=':'=':'.':rest) = "==.":lexer rest
 145 lexer ('/':'=':'.':rest) = "/=.":lexer rest
 146 lexer ('<':'=':'.':rest) = "<=.":lexer rest
 147 lexer ('>':'=':'.':rest) = ">=.":lexer rest
 148 lexer ('<':'.':rest) = "<.":lexer rest
 149 lexer ('>':'.':rest) = ">.":lexer rest
 150 lexer ('(':rest) = "(":lexer rest
 151 lexer (')':rest) = ")":lexer rest
 152 lexer ('_':rest) = "_":lexer rest
 153 lexer (d:rest)
 154     | isAlpha d = case span isAlpha (d:rest) of
 155         (s, rest') -> s:lexer rest'
 156     | isDigit d = case span isDigit (d:rest) of
 157         (s, rest') -> s:lexer rest'
 158 lexer (_:rest) = lexer rest
 159     -- | isSpace d = lexer rest
 160 lexer [] = []
 161
 162 quoteCPExp :: String -> Q Exp
 163 quoteCPExp s = do
 164     loc <- location
 165     let pos =  (loc_filename loc, fst (loc_start loc), snd (loc_start loc))
 166     parseCP pos s
 167
 168 quoteCPPat :: String -> Q Pat
 169 quoteCPPat _ = undefined