{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ParallelListComp #-}
-module Language.Quote where
+module Language.Quote (cp) where
import Data.Char
-import Data.List
-import Data.Maybe
-import Debug.Trace
-
-import Control.Applicative
+import Data.Functor.Identity
+--
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
-
+--
+import Text.Parsec
+import Text.Parsec.String
+import Text.Parsec.Expr as E
+import qualified Text.Parsec.Token as P
+import Text.Parsec.Language (haskell)
+--
import Language.GenDSL
cp :: QuasiQuoter
cp = QuasiQuoter
- { quoteExp = quoteCPExp
+ { quoteExp = \s->location >>= parseExpr s
, quotePat = undefined
, quoteType = undefined
, quoteDec = undefined
}
-
-newtype RParser m t a = Parser {runParser :: [t] -> m (a, [t])}
-type Parser t a = RParser Maybe t a
-instance Functor m => Functor (RParser m t) where
- fmap f m = Parser $ fmap (\(a, b)->(f a, b)) . runParser m
-instance Monad m => Applicative (RParser m t) where
- pure a = Parser $ pure . (a,)
- l <*> r = Parser $ \ts->runParser l ts >>= \(a, ts')->runParser r ts' >>= \(b, ts'')->pure (a b, ts'')
-instance Monad m => Monad (RParser m t) where
- ma >>= a2mb = Parser $ \ts->runParser ma ts >>= \(a, ts')->runParser (a2mb a) ts'
-instance (Monad m, Alternative m) => Alternative (RParser m t) where
- empty = Parser $ \_->empty
- l <|> r = Parser $ \ts->runParser l ts <|> runParser r ts
-instance (MonadFail m) => MonadFail (RParser m t) where
- fail msg = Parser $ \_->fail msg
-
-pTop :: Alternative m => RParser m t t
-pTop = Parser $ maybe empty pure . uncons
-
-pFail :: (MonadFail m, Alternative m) => String -> RParser m t a
-pFail msg = Parser $ \_->fail msg
-
-pSat :: (Alternative m, MonadFail m, Show t) => (t -> Bool) -> RParser m t t
-pSat p = pTop >>= \v->if p v then pure v else pFail ("unexpected: " ++ show v)
-
-pChainl :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a
-pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
-
-pChainr :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a
-pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
-
-pNonfix :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a
-pNonfix op p = flip id <$> p <*> op <*> p <|> p
-
-pSepBy :: (Monad m, Alternative m) => RParser m t s -> RParser m t a -> RParser m t [a]
-pSepBy sep el = (:) <$> el <*> many (sep *> el) <|> pure []
-
-pOptional :: (Monad m, Alternative m) => RParser m t a -> RParser m t (Maybe a)
-pOptional p = Just <$> p <|> pure Nothing
-
-pBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
-pBrack p = pSat (BOpen==) *> p <* pSat (BClose==)
-
-pCBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
-pCBrack p = pSat (COpen==) *> p <* pSat (CClose==)
-
-pCase :: (MonadFail m, Alternative m) => RParser m Token Exp
-pCase = mkCase <$ pSat (Case==) <*> pExp <* pSat (Of==) <*> some pCaseMatch
where
- mkCase :: Exp -> [(Pat, Exp)] -> Exp
- mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
+ parseExpr :: MonadFail m => String -> Loc -> m Exp
+ parseExpr s loc =
+ case runParser p () "" s of
+ Left err -> fail $ show err
+ Right e -> return e
where
- mkCaseMatch :: Pat -> Exp -> Exp -> Exp
- mkCaseMatch a e rest = case mkCasePred name a of
- Nothing -> mkCaseLets (mkCaseBinding name a []) e
- Just p -> VarE (mkName "if'") `AppE` p `AppE` (mkCaseLets (mkCaseBinding name a []) e) `AppE` rest
-
- mkCaseLets :: [Dec] -> Exp -> Exp
- mkCaseLets [] e = e
- mkCaseLets defs e = LetE defs e
-
- mkCasePred :: Exp -> Pat -> Maybe Exp
- mkCasePred objName (ConP consName fields) = Just $ foldl (ifx "&.")
- (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
- $ catMaybes $ [mkCasePred (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
- mkCasePred objName (RecP consName fields) = Just $ foldl (ifx "&.")
- (VarE (mkName $ "is" ++ stringName consName) `AppE` objName)
- $ catMaybes $ [mkCasePred (VarE (selectorName n) `AppE` objName) p | (n, p) <- fields]
- mkCasePred _ (VarP _) = Nothing
- mkCasePred _ WildP = Nothing
- mkCasePred objName (ParensP p) = mkCasePred objName p
- mkCasePred objName (AsP _ p) = mkCasePred objName p
- mkCasePred objName (LitP v) = Just (ifx "==." (VarE (mkName "lit") `AppE` LitE v) objName)
- mkCasePred _ p = error $ "Unsupported pat: " ++ show p
-
- mkCaseBinding :: Exp -> Pat -> [Dec] -> [Dec]
- mkCaseBinding objName (ConP consName fields) ds = foldr ($) ds $
- [mkCaseBinding (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]]
- mkCaseBinding objName (RecP _ fields) ds = foldr ($) ds $
- [mkCaseBinding (VarE (selectorName n) `AppE` objName) p| (n, p) <- fields]
- mkCaseBinding objName (VarP v) ds = FunD v [Clause [] (NormalB $ objName) []]:ds
- mkCaseBinding objName (AsP n v) ds = mkCaseBinding objName (VarP n) $ mkCaseBinding objName v ds
- mkCaseBinding _ (LitP _) ds = ds
- mkCaseBinding _ WildP ds = ds
- mkCaseBinding objName (ParensP p) ds = mkCaseBinding objName p ds
- mkCaseBinding _ p _ = error $ "Unsupported pat: " ++ show p
-
-pCaseMatch :: (MonadFail m, Alternative m) => RParser m Token (Pat, Exp)
-pCaseMatch = (,) <$> pPat <* pSat ((Op "->")==) <*> pExp <* optional (pSat (SColon==))
-
-pExp :: (MonadFail m, Alternative m) => RParser m Token Exp
-pExp
- = foldr ($) (pChainl (pure AppE) pBasic)
- [ pChainr $ parseOps ["^."]
- , pChainl $ parseOps ["*.", "/."]
- , pChainl $ parseOps ["+.", "-."]
- , pNonfix $ parseOps ["==.", "/=.", "<.", ">.", "<=.", ">=."]
- , pChainr $ parseOps ["&."]
- , pChainr $ parseOps ["|."]
- ]
- where
- parseOps :: (MonadFail m, Alternative m) => [String] -> RParser m Token (Exp -> Exp -> Exp)
- parseOps = foldr1 (<|>) . map (\op->ifx op <$ pSat ((Op op)==))
-
- pBasic :: (MonadFail m, Alternative m) => RParser m Token Exp
- pBasic
- = flip ($) . VarE <$> pVar <*> pFuncall
- <|> AppE (VarE (mkName "lit")) . LitE <$> pLit
- <|> pBrack pExp
- <|> pCase
-
- pFuncall :: (MonadFail m, Alternative m) => RParser m Token (Exp -> Exp)
- pFuncall = maybe id (flip AppE . TupE) <$> pOptional (pBrack (pSepBy (pSat (Comma==)) pExp))
-
-pLit :: (MonadFail m, Alternative m) => RParser m Token Lit
-pLit = unlit <$> pSat (\x->case x of Lit _ -> True; _ -> False)
-
-pVar :: (MonadFail m, Alternative m) => RParser m Token Name
-pVar = mkName . unvar <$> pSat (\x->case x of Var _ -> True; _ -> False)
-
-pCon :: (MonadFail m, Alternative m) => RParser m Token Name
-pCon = mkName . uncon <$> pSat (\x->case x of Con _ -> True; _ -> False)
-
-pPat :: (MonadFail m, Alternative m) => RParser m Token Pat
-pPat
- = RecP <$> pCon <*> pCBrack pFieldPat
- <|> ConP <$> pCon <*> many pPat
- <|> AsP <$> pVar <* pSat (At==) <*> pPat
- <|> VarP <$> pVar
- <|> WildP <$ pSat (Underscore==)
- <|> LitP <$> pLit
- <|> pBrack pPat
+ file = loc_filename loc
+ (line, col) = loc_start loc
+ p = getPosition >>= setPosition . mPos >> expr <* eof
+ mPos = (flip setSourceName) file .
+ (flip setSourceLine) line .
+ (flip setSourceColumn) col
+
+-- Lexer
+identifier,operator :: Parser String
+identifier = P.identifier haskell
+operator = P.operator haskell
+
+parens,braces :: Parser a -> Parser a
+braces = P.braces haskell
+parens = P.parens haskell
+
+commaSep :: Parser a -> Parser [a]
+commaSep = P.commaSep haskell
+
+symbol :: String -> Parser String
+symbol = P.symbol haskell
+
+reserved,reservedOp :: String -> Parser ()
+reserved = P.reserved haskell
+reservedOp = P.reservedOp haskell
+
+-- Parser
+pat :: Parser Pat
+pat
+ = try (RecP <$> con <*> braces (commaSep $ (,) <$> var <* reservedOp "=" <*> pat))
+ <|> ConP <$> con <*> many pat
+ <|> try (AsP <$> var <* reservedOp "@" <*> pat)
+ <|> VarP <$> var
+ <|> WildP <$ symbol "_"
+ <|> LitP <$> lit
+ <|> parens pat
+
+expr :: Parser Exp
+expr = buildExpressionParser
+ [ [bin "^." AssocRight]
+ , [bin "*." AssocLeft, bin "/." AssocLeft]
+ , [bin "+." AssocLeft, bin "-." AssocLeft]
+ , [bin o AssocNone | o <- ["==.", "/=.", "<.", ">.", "<=.", ">=."]]
+ , [bin "&." AssocRight]
+ , [bin "|." AssocRight]
+ ] basic
where
- pFieldPat = pSepBy (pSat (Comma==)) $
- (,) <$> pVar <* pSat (Equal==) <*> pPat
-
-parseCP :: MonadFail m => [Char] -> m Exp
---parseCP s = case runParser pCase (lexer s) of
-parseCP s = case runParser pExp (lexer (trace (show s) s)) of
- Nothing -> fail $ "Parsing failed for: " ++ show (lexer s)
--- [] -> fail $ "Parsing failed for: " ++ show (lexer s)
- Just (_, t@(_:_)) -> fail $ "Non-exhaustive parse found: " ++ show t
--- (e, []):_ -> pure e
--- x -> fail $ "Multiple parses: " ++ show x
- Just (e, []) -> pure e
-
-data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String}
- | Case | Of | Op String | BOpen | BClose | Underscore | SColon | At | COpen | CClose | Equal | Comma
- | Unknown Char
- deriving (Eq, Show)
-
-lexer :: [Char] -> [Token]
-lexer ('c':'a':'s':'e':rest) = Case:lexer rest
-lexer ('o':'f':rest) = Of:lexer rest
-lexer ('-':'>':rest) = Op "->":lexer rest
-lexer ('^':'.':rest) = Op "^.":lexer rest
-lexer ('*':'.':rest) = Op "*.":lexer rest
-lexer ('/':'.':rest) = Op "/.":lexer rest
-lexer ('+':'.':rest) = Op "+.":lexer rest
-lexer ('-':'.':rest) = Op "-.":lexer rest
-lexer ('|':'.':rest) = Op "|.":lexer rest
-lexer ('&':'.':rest) = Op "&.":lexer rest
-lexer ('=':'=':'.':rest) = Op "==.":lexer rest
-lexer ('/':'=':'.':rest) = Op "/=.":lexer rest
-lexer ('<':'=':'.':rest) = Op "<=.":lexer rest
-lexer ('>':'=':'.':rest) = Op ">=.":lexer rest
-lexer ('<':'.':rest) = Op "<.":lexer rest
-lexer ('>':'.':rest) = Op ">.":lexer rest
-lexer ('(':rest) = BOpen:lexer rest
-lexer (')':rest) = BClose:lexer rest
-lexer ('_':rest) = Underscore:lexer rest
-lexer (';':rest) = SColon:lexer rest
-lexer ('@':rest) = At:lexer rest
-lexer ('-':'-':rest) = lexer $ dropWhile (/='\n') rest
-lexer ('{':'-':rest) = gobble rest
+ bin :: String -> Assoc -> Operator String () Identity Exp
+ bin str = E.Infix $ ifx str <$ sat operator (str==)
+ (("Expected operator " ++ str ++ " but got ")++)
+
+ basic :: Parser Exp
+ basic
+ = try (AppE . VarE <$> var <*> (TupE <$> parens (commaSep expr)))
+ <|> VarE <$> var
+ <|> AppE (VarE (mkName "lit")) . LitE <$> lit
+ <|> parens expr
+ <|> mkCase <$ reserved "case" <*> expr <* reserved "of" <*> many1 match
+
+ match = (,) <$> pat <* reservedOp "->" <*> expr
+
+sat :: Parser a -> (a -> Bool) -> (a -> String) -> Parser a
+sat p f msg = try (p >>= \a->if f a then pure a else fail (msg a))
+
+lit :: Parser Lit
+lit
+ = CharL <$> P.charLiteral haskell
+ <|> IntegerL <$> P.natural haskell
+
+con,var :: Parser Name
+con = mkName <$> sat identifier (isUpper . head) ("Not a data constructor: "++)
+var = mkName <$> sat identifier (isLower . head) ("Not a variable identifier: "++)
+
+-- Convert case to if statements
+mkCase :: Exp -> [(Pat, Exp)] -> Exp
+mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
where
- gobble [] = []
- gobble ('-':'}':xs) = lexer xs
- gobble (_:xs) = gobble xs
-lexer ('{':rest) = COpen:lexer rest
-lexer ('}':rest) = CClose:lexer rest
-lexer ('=':rest) = Equal:lexer rest
-lexer (',':rest) = Comma:lexer rest
-lexer ('\'':'\\':x:'\'':rest) = case x of
- '\'' -> Lit (CharL '\''):lexer rest
- '\\' -> Lit (CharL '\\'):lexer rest
- 'a' -> Lit (CharL '\a'):lexer rest
- 'b' -> Lit (CharL '\b'):lexer rest
- 't' -> Lit (CharL '\t'):lexer rest
- 'n' -> Lit (CharL '\n'):lexer rest
- 'v' -> Lit (CharL '\v'):lexer rest
- 'f' -> Lit (CharL '\f'):lexer rest
- 'r' -> Lit (CharL '\r'):lexer rest
- _ -> error $ "Unknown character escape: " ++ show x
-lexer ('\'':x:'\'':rest)
- | x /= '\'' && x /= '\\'= Lit (CharL x):lexer rest
-lexer (d:rest)
- | isAlpha d && isUpper d = case span isAlpha rest of
- (s, rest') -> Con (d:s):lexer rest'
- | isAlpha d && isLower d = case span isAlpha rest of
- (s, rest') -> Var (d:s):lexer rest'
- | isDigit d || d == '-' || d == '+' = case span isDigit rest of
- (s, rest') -> trace (show (d:s)) $ Lit (IntegerL $ read (d:s)):lexer rest'
- | isSpace d = lexer rest
- | otherwise = Unknown d:lexer rest
-lexer [] = []
-
-quoteCPExp :: String -> Q Exp
-quoteCPExp s = do
--- loc <- location
--- let pos = (loc_filename loc, fst (loc_start loc), snd (loc_start loc))
- parseCP s
-
-quoteCPPat :: String -> Q Pat
-quoteCPPat _ = undefined
+ mkCaseMatch :: Pat -> Exp -> Exp -> Exp
+ mkCaseMatch a e rest = case mkCasePred name a of
+ [] -> mkCaseLets (mkCaseBinding name a) e
+ ps -> VarE (mkName "if'") `AppE` foldl1 (ifx "&.") ps `AppE` (mkCaseLets (mkCaseBinding name a) e) `AppE` rest
+
+ mkCaseLets :: [Dec] -> Exp -> Exp
+ mkCaseLets [] e = e
+ mkCaseLets defs e = LetE defs e
+
+ conPtoRecP :: Name -> [Pat] -> Pat
+ conPtoRecP consName = RecP consName . zip (map (adtFieldName consName) [0..])
+
+ mkCasePred :: Exp -> Pat -> [Exp]
+ mkCasePred e (LitP l) = [ifx "==." (VarE (mkName "lit") `AppE` LitE l) e]
+ mkCasePred _ (VarP _) = []
+ mkCasePred e (ConP cons fs) = mkCasePred e $ conPtoRecP cons fs
+ mkCasePred e (InfixP l cons r) = mkCasePred e (ConP cons [l,r])
+ mkCasePred e (UInfixP l cons r) = mkCasePred e (ConP cons [l,r])
+ mkCasePred e (ParensP p) = mkCasePred e p
+ mkCasePred e (TildeP p) = mkCasePred e p
+ mkCasePred e (BangP p) = mkCasePred e p
+ mkCasePred e (AsP _ p) = mkCasePred e p
+ mkCasePred _ WildP = []
+ mkCasePred e (RecP cons fs) = VarE (predicateName cons) `AppE` e
+ : concatMap (\(n, p)->mkCasePred (VarE (selectorName n) `AppE` e) p) fs
+ mkCasePred _ p = error $ "Unsupported pat: " ++ show p
+
+ mkCaseBinding :: Exp -> Pat -> [Dec]
+ mkCaseBinding _ (LitP _) = []
+ mkCaseBinding e (VarP v) = [FunD v [Clause [] (NormalB $ e) []]]
+ mkCaseBinding e (ConP cons fs) = mkCaseBinding e $ conPtoRecP cons fs
+ mkCaseBinding e (InfixP l cons r) = mkCaseBinding e (ConP cons [l,r])
+ mkCaseBinding e (UInfixP l cons r) = mkCaseBinding e (ConP cons [l,r])
+ mkCaseBinding e (ParensP p) = mkCaseBinding e p
+ mkCaseBinding e (TildeP p) = mkCaseBinding e p
+ mkCaseBinding e (BangP p) = mkCaseBinding e p
+ mkCaseBinding e (AsP n p) = FunD n [Clause [] (NormalB $ e) []]:mkCaseBinding e p
+ mkCaseBinding _ WildP = []
+ mkCaseBinding e (RecP _ fs) = concatMap (\(n, p)->mkCaseBinding (VarE (selectorName n) `AppE` e) p) fs
+ mkCaseBinding _ p = error $ "Unsupported pat: " ++ show p
repositories / clean-tests.git / commitdiff