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 Data.Maybe
  10 import Debug.Trace
  11
  12 import Control.Applicative
  13 import Language.Haskell.TH.Syntax
  14 import Language.Haskell.TH.Quote
  15
  16 import Language.GenDSL
  17
  18 cp :: QuasiQuoter
  19 cp = QuasiQuoter
  20     { quoteExp = quoteCPExp
  21     , quotePat = undefined
  22     , quoteType = undefined
  23     , quoteDec = undefined
  24     }
  25
  26 newtype RParser m t a = Parser {runParser :: [t] -> m (a, [t])}
  27 type Parser t a = RParser Maybe t a
  28 instance Functor m => Functor (RParser m t) where
  29     fmap f m = Parser $ fmap (\(a, b)->(f a, b)) . runParser m
  30 instance Monad m => Applicative (RParser m t) where
  31     pure a = Parser $ pure . (a,)
  32     l <*> r = Parser $ \ts->runParser l ts >>= \(a, ts')->runParser r ts' >>= \(b, ts'')->pure (a b, ts'')
  33 instance Monad m => Monad (RParser m t) where
  34     ma >>= a2mb = Parser $ \ts->runParser ma ts >>= \(a, ts')->runParser (a2mb a) ts'
  35 instance (Monad m, Alternative m) => Alternative (RParser m t) where
  36     empty = Parser $ \_->empty
  37     l <|> r = Parser $ \ts->runParser l ts <|> runParser r ts
  38 instance (MonadFail m) => MonadFail (RParser m t) where
  39     fail msg = Parser $ \_->fail msg
  40
  41 pTop :: Alternative m => RParser m t t
  42 pTop = Parser $ maybe empty pure . uncons
  43
  44 pFail :: (MonadFail m, Alternative m) => String -> RParser m t a
  45 pFail msg = Parser $ \_->fail msg
  46
  47 pSat :: (Alternative m, MonadFail m, Show t) => (t -> Bool) -> RParser m t t
  48 pSat p = pTop >>= \v->if p v then pure v else pFail ("unexpected: " ++ show v)
  49
  50 pChainl :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a
  51 pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
  52
  53 pChainr :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a
  54 pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
  55
  56 pNonfix :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a
  57 pNonfix op p = flip id <$> p <*> op <*> p <|> p
  58
  59 pSepBy :: (Monad m, Alternative m) => RParser m t s -> RParser m t a -> RParser m t [a]
  60 pSepBy sep el = (:) <$> el <*> many (sep *> el) <|> pure []
  61
  62 pBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
  63 pBrack p = pSat (BOpen==) *> p <* pSat (BClose==)
  64
  65 pCBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
  66 pCBrack p = pSat (COpen==) *> p <* pSat (CClose==)
  67
  68 pCase :: (MonadFail m, Alternative m) => RParser m Token Exp
  69 pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch
  70   where
  71     mkCase :: Exp -> [(Pat, Exp)] -> Exp
  72     mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
  73       where
  74         mkCaseMatch :: Pat -> Exp -> Exp -> Exp
  75         mkCaseMatch a e rest = case mkCasePred name a of
  76             Nothing -> mkCaseLets (mkCaseBinding name a []) e
  77             Just p -> VarE (mkName "if'") `AppE` p `AppE` (mkCaseLets (mkCaseBinding name a []) e) `AppE` rest
  78
  79         mkCaseLets :: [Dec] -> Exp -> Exp
  80         mkCaseLets [] e = e
  81         mkCaseLets defs e = LetE defs e
  82
  83         mkCasePred :: Exp -> Pat -> Maybe Exp
  84         mkCasePred objName (ConP consName fields) = Just $ foldl (ifx "&.")
  85             (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
  86             $ catMaybes $ [mkCasePred (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
  87         mkCasePred objName (RecP consName fields) = Just $ foldl (ifx "&.")
  88             (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
  89             $ catMaybes $ [mkCasePred (VarE (selectorName n) `AppE` objName) p | (n, p) <- fields]
  90         mkCasePred _ (VarP _) = Nothing
  91         mkCasePred _ WildP = Nothing
  92         mkCasePred objName (ParensP p) = mkCasePred objName p
  93         mkCasePred objName (AsP _ p) = mkCasePred objName p
  94         mkCasePred objName (LitP v) = Just (ifx "==." (VarE (mkName "lit") `AppE` LitE v) objName)
  95         mkCasePred _ p = error $ "Unsupported pat: " ++ show p
  96
  97         mkCaseBinding :: Exp -> Pat -> [Dec] -> [Dec]
  98         mkCaseBinding objName (ConP consName fields) ds = foldr ($) ds $
  99             [mkCaseBinding (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
 100         mkCaseBinding objName (RecP _ fields) ds = foldr ($) ds $
 101             [mkCaseBinding (VarE (selectorName n) `AppE` objName) p| (n, p) <- fields]
 102         mkCaseBinding objName (VarP v) ds = FunD v [Clause [] (NormalB $ objName) []]:ds
 103         mkCaseBinding objName (AsP n v) ds = mkCaseBinding objName (VarP n) $ mkCaseBinding objName v ds
 104         mkCaseBinding _ (LitP _) ds = ds
 105         mkCaseBinding _ WildP ds = ds
 106         mkCaseBinding objName (ParensP p) ds = mkCaseBinding objName p ds
 107         mkCaseBinding _ p _ = error $ "Unsupported pat: " ++ show p
 108
 109 pCaseMatch :: (MonadFail m, Alternative m) => RParser m Token (Pat, Exp)
 110 pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp <* optional (pSat (==SColon))
 111
 112 pExp :: (MonadFail m, Alternative m) => RParser m Token Exp
 113 pExp
 114     = foldr ($) (pChainl (pure AppE) pBasic)
 115     [ pChainr $ parseOps ["^."]
 116     , pChainl $ parseOps ["*.", "/."]
 117     , pChainl $ parseOps ["+.", "-."]
 118     , pNonfix $ parseOps ["==.", "/=.", "<.", ">.", "<=.", ">=."]
 119     , pChainr $ parseOps ["&."]
 120     , pChainr $ parseOps ["|."]
 121     ]
 122   where
 123     parseOps = foldr1 (<|>) . map (\op->ifx op <$ pSat (==(Op op)))
 124
 125     pBasic
 126         =   VarE <$> pVar
 127         <|> AppE (VarE (mkName "lit")) . LitE <$> pLit
 128         <|> pBrack pExp
 129
 130 pLit :: (MonadFail m, Alternative m) => RParser m Token Lit
 131 pLit = unlit <$> pSat (\x->case x of Lit _ -> True; _ -> False)
 132
 133 pVar :: (MonadFail m, Alternative m) => RParser m Token Name
 134 pVar = mkName . unvar <$> pSat (\x->case x of Var _ -> True; _ -> False)
 135
 136 pCon :: (MonadFail m, Alternative m) => RParser m Token Name
 137 pCon = mkName . uncon <$> pSat (\x->case x of Con _ -> True; _ -> False)
 138
 139 pPat :: (MonadFail m, Alternative m) => RParser m Token Pat
 140 pPat
 141     =   RecP <$> pCon <*> pCBrack pFieldPat
 142     <|> ConP <$> pCon <*> many pPat
 143     <|> AsP <$> pVar <* pSat (At==) <*> pPat
 144     <|> VarP <$> pVar
 145     <|> WildP <$ pSat (Underscore==)
 146     <|> LitP <$> pLit
 147     <|> pBrack pPat
 148   where
 149     pFieldPat = pSepBy (pSat (==Comma)) $
 150         (,) <$> pVar <* pSat (==Equal) <*> pPat
 151
 152 parseCP :: MonadFail m => [Char] -> m Exp
 153 --parseCP s = case runParser pCase (lexer s) of
 154 parseCP s = case runParser pCase (lexer (trace (show s) s)) of
 155     Nothing -> fail $ "Parsing failed for: " ++ show (lexer s)
 156 --    [] -> fail $ "Parsing failed for: " ++ show (lexer s)
 157     Just (_, t@(_:_)) -> fail $ "Non-exhaustive parse found: " ++ show t
 158 --    (e, []):_ -> pure e
 159 --    x -> fail $ "Multiple parses: " ++ show x
 160     Just (e, []) -> pure e
 161
 162 data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String}
 163     | Case | Of | Op String | BOpen | BClose | Underscore | SColon | At | COpen | CClose | Equal | Comma
 164     | Unknown Char
 165   deriving (Eq, Show)
 166
 167 lexer :: [Char] -> [Token]
 168 lexer ('c':'a':'s':'e':rest) = Case:lexer rest
 169 lexer ('o':'f':rest) = Of:lexer rest
 170 lexer ('-':'>':rest) = Op "->":lexer rest
 171 lexer ('^':'.':rest) = Op "^.":lexer rest
 172 lexer ('*':'.':rest) = Op "*.":lexer rest
 173 lexer ('/':'.':rest) = Op "/.":lexer rest
 174 lexer ('+':'.':rest) = Op "+.":lexer rest
 175 lexer ('-':'.':rest) = Op "-.":lexer rest
 176 lexer ('|':'.':rest) = Op "|.":lexer rest
 177 lexer ('&':'.':rest) = Op "&.":lexer rest
 178 lexer ('=':'=':'.':rest) = Op "==.":lexer rest
 179 lexer ('/':'=':'.':rest) = Op "/=.":lexer rest
 180 lexer ('<':'=':'.':rest) = Op "<=.":lexer rest
 181 lexer ('>':'=':'.':rest) = Op ">=.":lexer rest
 182 lexer ('<':'.':rest) = Op "<.":lexer rest
 183 lexer ('>':'.':rest) = Op ">.":lexer rest
 184 lexer ('(':rest) = BOpen:lexer rest
 185 lexer (')':rest) = BClose:lexer rest
 186 lexer ('_':rest) = Underscore:lexer rest
 187 lexer (';':rest) = SColon:lexer rest
 188 lexer ('@':rest) = At:lexer rest
 189 lexer ('-':'-':rest) = lexer $ dropWhile (/='\n') rest
 190 lexer ('{':'-':rest) = gobble rest
 191   where
 192     gobble [] = []
 193     gobble ('-':'}':xs) = lexer xs
 194     gobble (_:xs) = gobble xs
 195 lexer ('{':rest) = COpen:lexer rest
 196 lexer ('}':rest) = CClose:lexer rest
 197 lexer ('=':rest) = Equal:lexer rest
 198 lexer (',':rest) = Comma:lexer rest
 199 lexer ('\'':'\\':x:'\'':rest) = case x of
 200         '\'' -> Lit (CharL '\''):lexer rest
 201         '\\' -> Lit (CharL '\\'):lexer rest
 202         'a' -> Lit (CharL '\a'):lexer rest
 203         'b' -> Lit (CharL '\b'):lexer rest
 204         't' -> Lit (CharL '\t'):lexer rest
 205         'n' -> Lit (CharL '\n'):lexer rest
 206         'v' -> Lit (CharL '\v'):lexer rest
 207         'f' -> Lit (CharL '\f'):lexer rest
 208         'r' -> Lit (CharL '\r'):lexer rest
 209         _ -> error $ "Unknown character escape: " ++ show x
 210 lexer ('\'':x:'\'':rest)
 211     | x /= '\'' && x /= '\\'= Lit (CharL x):lexer rest
 212 lexer (d:rest)
 213     | isAlpha d && isUpper d = case span isAlpha rest of
 214         (s, rest') -> Con (d:s):lexer rest'
 215     | isAlpha d && isLower d = case span isAlpha rest of
 216         (s, rest') -> Var (d:s):lexer rest'
 217     | isDigit d || d == '-' || d == '+' = case span isDigit rest of
 218         (s, rest') -> trace (show (d:s)) $ Lit (IntegerL $ read (d:s)):lexer rest'
 219     | isSpace d = lexer rest
 220     | otherwise = Unknown d:lexer rest
 221 lexer [] = []
 222
 223 quoteCPExp :: String -> Q Exp
 224 quoteCPExp s = do
 225 --   loc <- location
 226 --    let pos =  (loc_filename loc, fst (loc_start loc), snd (loc_start loc))
 227     parseCP s
 228
 229 quoteCPPat :: String -> Q Pat
 230 quoteCPPat _ = undefined