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