import Debug.Trace
import Control.Applicative
-import Control.Monad
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
-import Language.Haskell.TH
-import Language
import Language.GenDSL
cp :: QuasiQuoter
, quoteDec = undefined
}
-appFst f (a, b) = (f a, b)
-
-newtype Parser t a = Parser {runParser :: [t] -> Maybe (a, [t])}
-instance Functor (Parser t) where
- fmap f m = Parser $ fmap (appFst f) . runParser m
-instance Applicative (Parser t) where
- pure a = Parser $ Just . (a,)
+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 (Parser t) where
+instance Monad m => Monad (RParser m t) where
ma >>= a2mb = Parser $ \ts->runParser ma ts >>= \(a, ts')->runParser (a2mb a) ts'
-instance Alternative (Parser t) where
- empty = Parser $ \_->Nothing
+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 :: Parser t t
-pTop = Parser uncons
-
-pFail :: Parser t a
-pFail = Parser $ \_->Nothing
+pTop :: Alternative m => RParser m t t
+pTop = Parser $ maybe empty pure . uncons
-pSatisfy :: (t -> Bool) -> Parser t t
-pSatisfy pred = pTop >>= \v->if pred v then pure v else pFail
+pFail :: (MonadFail m, Alternative m) => String -> RParser m t a
+pFail msg = Parser $ \_->fail msg
-pToken :: Eq t => t -> Parser t t
-pToken t = pSatisfy (t==)
+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 :: Parser t (a -> a -> a) -> Parser t a -> Parser t a
+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 :: Parser t (a -> a -> a) -> Parser t a -> Parser t a
+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 :: Parser t (a -> a -> a) -> Parser t a -> Parser t a
-pNonfix op p = (\l op r->l `op` r) <$> p <*> 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 :: Parser t s -> Parser t a -> Parser t [a]
+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 []
-pBrack :: Parser String s -> Parser String s
-pBrack p = pToken "(" *> p <* pToken ")"
+pBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s
+pBrack p = pSat (BOpen==) *> p <* pSat (BClose==)
-pCase :: Parser String Exp
-pCase = mkCase <$ pToken "case" <*> pExp <* pToken "of" <*> some pCaseMatch
+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
mkCaseMatch (ConP consName fields) e rest
= VarE (mkName "if'")
`AppE` (VarE (mkName $ "is" ++ stringName consName) `AppE` name) --Predicate
- `AppE` LetE [mkFieldMatch idx f | f <- fields | idx <- [0..]] e
+ `AppE` LetE [mkFieldMatch idx f | f <- fields | idx <- [0 :: Int ..]] e
`AppE` rest
where
mkFieldMatch idx (VarP v) = FunD v [Clause [] (NormalB $ VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` name) []]
+-- mkFieldMatch idx p@(ConP consName fields) = FunD (mkName "f0") [Clause [] (NormalB $ mkCaseMatch p e (LitE (StringL "Exhausted case"))) []]
+ mkFieldMatch _ p = error $ "Unsupported subpat: " ++ show p
+
+ mkCaseMatch p _ _ = error $ "Unsupported pat: " ++ show p
-pCaseMatch :: Parser String (Pat, Exp)
-pCaseMatch = (,) <$> pPat <* pToken "->" <*> pExp
+pCaseMatch :: (MonadFail m, Alternative m) => RParser m Token (Pat, Exp)
+pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp
-pExp :: Parser String Exp
+pExp :: (MonadFail m, Alternative m) => RParser m Token Exp
pExp
= foldr ($) (pChainl (pure AppE) pBasic)
[ pChainr $ parseOps ["^."]
, pChainr $ parseOps ["|."]
]
where
- parseOps = foldr1 (<|>) . map (\op->ifx op <$ pToken op)
+ parseOps = foldr1 (<|>) . map (\op->ifx op <$ pSat (==(Op op)))
- pBasic :: Parser String Exp
pBasic
= VarE <$> pVar
<|> AppE (VarE (mkName "lit")) . LitE <$> pLit
<|> pBrack pExp
-pLit :: Parser String Lit
-pLit
--- = CharL <$ pToken '\'' <*> pTop <* pToken '\''
- = (IntegerL . read) <$> pSatisfy (all isDigit)
+pLit :: (MonadFail m, Alternative m) => RParser m Token Lit
+pLit = unlit <$> pSat (\x->case x of Lit _ -> True; _ -> False)
-pVar :: Parser String Name
-pVar = mkName <$> pSatisfy (\x->isLower (head x) && all isAlpha x && Prelude.not (x `elem` kw))
+pVar :: (MonadFail m, Alternative m) => RParser m Token Name
+pVar = mkName . unvar <$> pSat (\x->case x of Var _ -> True; _ -> False)
-pCon :: Parser String Name
-pCon = mkName <$> pSatisfy (\x->isUpper (head x) && all isAlpha x && Prelude.not (x `elem` kw))
+pCon :: (MonadFail m, Alternative m) => RParser m Token Name
+pCon = mkName . uncon <$> pSat (\x->case x of Con _ -> True; _ -> False)
-kw = ["case", "of"]
-
-pPat :: Parser String Pat
+pPat :: (MonadFail m, Alternative m) => RParser m Token Pat
pPat
= ConP <$> pCon <*> many pPat
<|> VarP <$> pVar
- <|> WildP <$ pToken "_"
-
-parseCP (file, line, col) s =
- case runParser pCase (let ts = lexer s in trace (show ts) ts) of
- Nothing -> fail "Parsing failed"
- Just (_, _:_) -> fail "Non-exhaustive parse found"
- Just (e, []) -> pure e
-
-lexer :: [Char] -> [String]
-lexer ('c':'a':'s':'e':rest) = "case":lexer rest
-lexer ('o':'f':rest) = "of":lexer rest
-lexer ('-':'>':rest) = "->":lexer rest
-lexer ('^':'.':rest) = "^.":lexer rest
-lexer ('*':'.':rest) = "*.":lexer rest
-lexer ('/':'.':rest) = "/.":lexer rest
-lexer ('+':'.':rest) = "+.":lexer rest
-lexer ('-':'.':rest) = "-.":lexer rest
-lexer ('|':'.':rest) = "|.":lexer rest
-lexer ('&':'.':rest) = "&.":lexer rest
-lexer ('=':'=':'.':rest) = "==.":lexer rest
-lexer ('/':'=':'.':rest) = "/=.":lexer rest
-lexer ('<':'=':'.':rest) = "<=.":lexer rest
-lexer ('>':'=':'.':rest) = ">=.":lexer rest
-lexer ('<':'.':rest) = "<.":lexer rest
-lexer ('>':'.':rest) = ">.":lexer rest
-lexer ('(':rest) = "(":lexer rest
-lexer (')':rest) = ")":lexer rest
-lexer ('_':rest) = "_":lexer rest
+ <|> WildP <$ pSat (Underscore==)
+ <|> pBrack pPat
+
+parseCP :: MonadFail m => [Char] -> m Exp
+parseCP s = case runParser pCase (lexer s) of
+ Nothing -> fail "Parsing failed"
+ Just (_, _:_) -> fail "Non-exhaustive parse found"
+ Just (e, []) -> pure e
+
+data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String} | Case | Of | Op String | BOpen | BClose | Underscore | 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 ('\'':'\\':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 ('-':'-':rest) = lexer $ dropWhile (/='\n') rest
+lexer ('{':'-':rest) = gobble rest
+ where
+ gobble [] = []
+ gobble ('-':'}':xs) = lexer xs
+ gobble (_:xs) = gobble xs
lexer (d:rest)
- | isAlpha d = case span isAlpha (d:rest) of
- (s, rest') -> s:lexer rest'
- | isDigit d = case span isDigit (d:rest) of
- (s, rest') -> s:lexer rest'
-lexer (_:rest) = lexer rest
- -- | isSpace d = lexer 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') -> 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 pos s
+-- loc <- location
+-- let pos = (loc_filename loc, fst (loc_start loc), snd (loc_start loc))
+ parseCP s
quoteCPPat :: String -> Q Pat
quoteCPPat _ = undefined
repositories / clean-tests.git / blobdiff