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 pOptional :: (Monad m, Alternative m) => RParser m t a -> RParser m t (Maybe a)
  63 pOptional p = Just <$> p <|> pure Nothing
  64
  65 pBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
  66 pBrack p = pSat (BOpen==) *> p <* pSat (BClose==)
  67
  68 pCBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
  69 pCBrack p = pSat (COpen==) *> p <* pSat (CClose==)
  70
  71 pCase :: (MonadFail m, Alternative m) => RParser m Token Exp
  72 pCase = mkCase <$ pSat (Case==) <*> pExp <* pSat (Of==) <*> some pCaseMatch
  73   where
  74     mkCase :: Exp -> [(Pat, Exp)] -> Exp
  75     mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
  76       where
  77         mkCaseMatch :: Pat -> Exp -> Exp -> Exp
  78         mkCaseMatch a e rest = case mkCasePred name a of
  79             Nothing -> mkCaseLets (mkCaseBinding name a []) e
  80             Just p -> VarE (mkName "if'") `AppE` p `AppE` (mkCaseLets (mkCaseBinding name a []) e) `AppE` rest
  81
  82         mkCaseLets :: [Dec] -> Exp -> Exp
  83         mkCaseLets [] e = e
  84         mkCaseLets defs e = LetE defs e
  85
  86         mkCasePred :: Exp -> Pat -> Maybe Exp
  87         mkCasePred objName (ConP consName fields) = Just $ foldl (ifx "&.")
  88             (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
  89             $ catMaybes $ [mkCasePred (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
  90         mkCasePred objName (RecP consName fields) = Just $ foldl (ifx "&.")
  91             (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
  92             $ catMaybes $ [mkCasePred (VarE (selectorName n) `AppE` objName) p | (n, p) <- fields]
  93         mkCasePred _ (VarP _) = Nothing
  94         mkCasePred _ WildP = Nothing
  95         mkCasePred objName (ParensP p) = mkCasePred objName p
  96         mkCasePred objName (AsP _ p) = mkCasePred objName p
  97         mkCasePred objName (LitP v) = Just (ifx "==." (VarE (mkName "lit") `AppE` LitE v) objName)
  98         mkCasePred _ p = error $ "Unsupported pat: " ++ show p
  99
 100         mkCaseBinding :: Exp -> Pat -> [Dec] -> [Dec]
 101         mkCaseBinding objName (ConP consName fields) ds = foldr ($) ds $
 102             [mkCaseBinding (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
 103         mkCaseBinding objName (RecP _ fields) ds = foldr ($) ds $
 104             [mkCaseBinding (VarE (selectorName n) `AppE` objName) p| (n, p) <- fields]
 105         mkCaseBinding objName (VarP v) ds = FunD v [Clause [] (NormalB $ objName) []]:ds
 106         mkCaseBinding objName (AsP n v) ds = mkCaseBinding objName (VarP n) $ mkCaseBinding objName v ds
 107         mkCaseBinding _ (LitP _) ds = ds
 108         mkCaseBinding _ WildP ds = ds
 109         mkCaseBinding objName (ParensP p) ds = mkCaseBinding objName p ds
 110         mkCaseBinding _ p _ = error $ "Unsupported pat: " ++ show p
 111
 112 pCaseMatch :: (MonadFail m, Alternative m) => RParser m Token (Pat, Exp)
 113 pCaseMatch = (,) <$> pPat <* pSat ((Op "->")==) <*> pExp <* optional (pSat (SColon==))
 114
 115 pExp :: (MonadFail m, Alternative m) => RParser m Token Exp
 116 pExp
 117     = foldr ($) (pChainl (pure AppE) pBasic)
 118     [ pChainr $ parseOps ["^."]
 119     , pChainl $ parseOps ["*.", "/."]
 120     , pChainl $ parseOps ["+.", "-."]
 121     , pNonfix $ parseOps ["==.", "/=.", "<.", ">.", "<=.", ">=."]
 122     , pChainr $ parseOps ["&."]
 123     , pChainr $ parseOps ["|."]
 124     ]
 125   where
 126     parseOps :: (MonadFail m, Alternative m) => [String] -> RParser m Token (Exp -> Exp -> Exp)
 127     parseOps = foldr1 (<|>) . map (\op->ifx op <$ pSat ((Op op)==))
 128
 129     pBasic :: (MonadFail m, Alternative m) => RParser m Token Exp
 130     pBasic
 131         =   flip ($) . VarE <$> pVar <*> pFuncall
 132         <|> AppE (VarE (mkName "lit")) . LitE <$> pLit
 133         <|> pBrack pExp
 134         <|> pCase
 135
 136     pFuncall :: (MonadFail m, Alternative m) => RParser m Token (Exp -> Exp)
 137     pFuncall = maybe id (flip AppE . TupE) <$> pOptional (pBrack (pSepBy (pSat (Comma==)) pExp))
 138
 139 pLit :: (MonadFail m, Alternative m) => RParser m Token Lit
 140 pLit = unlit <$> pSat (\x->case x of Lit _ -> True; _ -> False)
 141
 142 pVar :: (MonadFail m, Alternative m) => RParser m Token Name
 143 pVar = mkName . unvar <$> pSat (\x->case x of Var _ -> True; _ -> False)
 144
 145 pCon :: (MonadFail m, Alternative m) => RParser m Token Name
 146 pCon = mkName . uncon <$> pSat (\x->case x of Con _ -> True; _ -> False)
 147
 148 pPat :: (MonadFail m, Alternative m) => RParser m Token Pat
 149 pPat
 150     =   RecP <$> pCon <*> pCBrack pFieldPat
 151     <|> ConP <$> pCon <*> many pPat
 152     <|> AsP <$> pVar <* pSat (At==) <*> pPat
 153     <|> VarP <$> pVar
 154     <|> WildP <$ pSat (Underscore==)
 155     <|> LitP <$> pLit
 156     <|> pBrack pPat
 157   where
 158     pFieldPat = pSepBy (pSat (Comma==)) $
 159         (,) <$> pVar <* pSat (Equal==) <*> pPat
 160
 161 parseCP :: MonadFail m => [Char] -> m Exp
 162 --parseCP s = case runParser pCase (lexer s) of
 163 parseCP s = case runParser pExp (lexer (trace (show s) s)) of
 164     Nothing -> fail $ "Parsing failed for: " ++ show (lexer s)
 165 --    [] -> fail $ "Parsing failed for: " ++ show (lexer s)
 166     Just (_, t@(_:_)) -> fail $ "Non-exhaustive parse found: " ++ show t
 167 --    (e, []):_ -> pure e
 168 --    x -> fail $ "Multiple parses: " ++ show x
 169     Just (e, []) -> pure e
 170
 171 data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String}
 172     | Case | Of | Op String | BOpen | BClose | Underscore | SColon | At | COpen | CClose | Equal | Comma
 173     | Unknown Char
 174   deriving (Eq, Show)
 175
 176 lexer :: [Char] -> [Token]
 177 lexer ('c':'a':'s':'e':rest) = Case:lexer rest
 178 lexer ('o':'f':rest) = Of: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) = Op "-.":lexer rest
 185 lexer ('|':'.':rest) = Op "|.":lexer rest
 186 lexer ('&':'.':rest) = Op "&.":lexer rest
 187 lexer ('=':'=':'.':rest) = Op "==.":lexer rest
 188 lexer ('/':'=':'.':rest) = Op "/=.":lexer rest
 189 lexer ('<':'=':'.':rest) = Op "<=.":lexer rest
 190 lexer ('>':'=':'.':rest) = Op ">=.":lexer rest
 191 lexer ('<':'.':rest) = Op "<.":lexer rest
 192 lexer ('>':'.':rest) = Op ">.":lexer rest
 193 lexer ('(':rest) = BOpen:lexer rest
 194 lexer (')':rest) = BClose:lexer rest
 195 lexer ('_':rest) = Underscore:lexer rest
 196 lexer (';':rest) = SColon:lexer rest
 197 lexer ('@':rest) = At:lexer rest
 198 lexer ('-':'-':rest) = lexer $ dropWhile (/='\n') rest
 199 lexer ('{':'-':rest) = gobble rest
 200   where
 201     gobble [] = []
 202     gobble ('-':'}':xs) = lexer xs
 203     gobble (_:xs) = gobble xs
 204 lexer ('{':rest) = COpen:lexer rest
 205 lexer ('}':rest) = CClose:lexer rest
 206 lexer ('=':rest) = Equal:lexer rest
 207 lexer (',':rest) = Comma:lexer rest
 208 lexer ('\'':'\\':x:'\'':rest) = case x of
 209         '\'' -> Lit (CharL '\''):lexer rest
 210         '\\' -> Lit (CharL '\\'):lexer rest
 211         'a' -> Lit (CharL '\a'):lexer rest
 212         'b' -> Lit (CharL '\b'):lexer rest
 213         't' -> Lit (CharL '\t'):lexer rest
 214         'n' -> Lit (CharL '\n'):lexer rest
 215         'v' -> Lit (CharL '\v'):lexer rest
 216         'f' -> Lit (CharL '\f'):lexer rest
 217         'r' -> Lit (CharL '\r'):lexer rest
 218         _ -> error $ "Unknown character escape: " ++ show x
 219 lexer ('\'':x:'\'':rest)
 220     | x /= '\'' && x /= '\\'= Lit (CharL x):lexer rest
 221 lexer (d:rest)
 222     | isAlpha d && isUpper d = case span isAlpha rest of
 223         (s, rest') -> Con (d:s):lexer rest'
 224     | isAlpha d && isLower d = case span isAlpha rest of
 225         (s, rest') -> Var (d:s):lexer rest'
 226     | isDigit d || d == '-' || d == '+' = case span isDigit rest of
 227         (s, rest') -> trace (show (d:s)) $ Lit (IntegerL $ read (d:s)):lexer rest'
 228     | isSpace d = lexer rest
 229     | otherwise = Unknown d:lexer rest
 230 lexer [] = []
 231
 232 quoteCPExp :: String -> Q Exp
 233 quoteCPExp s = do
 234 --   loc <- location
 235 --    let pos =  (loc_filename loc, fst (loc_start loc), snd (loc_start loc))
 236     parseCP s
 237
 238 quoteCPPat :: String -> Q Pat
 239 quoteCPPat _ = undefined