From dad9c516619f2f3e09ba3fb5959a1f270c44f892 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Thu, 2 Sep 2021 13:44:29 +0200 Subject: [PATCH] use parsec for the parser --- datatype/Language/GenDSL.hs | 5 +- datatype/Language/Quote.hs | 350 ++++++++++++++---------------------- datatype/Main.hs | 20 +-- 3 files changed, 145 insertions(+), 230 deletions(-) diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs index 69dff4b..47a6b29 100644 --- a/datatype/Language/GenDSL.hs +++ b/datatype/Language/GenDSL.hs @@ -19,11 +19,14 @@ stringName (Name occ _) = occString occ numberedArgs :: [a] -> Q [Name] numberedArgs = zipWithM (\i _->newName $ "f" ++ show i) [0 :: Int ..] +adtFieldName :: Name -> Int -> Name +adtFieldName consName idx = mkName $ map toLower (stringName consName) ++ "f" ++ show idx + data Field = Field { fname :: Name, ffresh :: Name, ftype :: Type } toNameType :: Con -> Q [Field] toNameType (NormalC consName fs) = numberedArgs fs - >>= \nfs->pure [Field (mkName $ map toLower (stringName consName) ++ "f" ++ show i) nf t | (_, t) <- fs | nf <- nfs | i <- [0 :: Int ..]] + >>= \nfs->pure [Field (adtFieldName consName i) nf t | (_, t) <- fs | nf <- nfs | i <- [0 :: Int ..]] toNameType (RecC _ fs) = numberedArgs fs >>= \nfs->pure [Field n nf t | (n, _, t)<-fs | nf <- nfs] toNameType c = fail $ "Unsupported constructor type: " ++ show c diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs index f062647..6e9e373 100644 --- a/datatype/Language/Quote.hs +++ b/datatype/Language/Quote.hs @@ -2,238 +2,150 @@ {-# 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 diff --git a/datatype/Main.hs b/datatype/Main.hs index 8d31f60..c68cb85 100644 --- a/datatype/Main.hs +++ b/datatype/Main.hs @@ -35,12 +35,12 @@ main -- >> putStrLn (show $ runInterpreter (unmain f4)) >> putStrLn (runPrint $ unmain f5) >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f5)) - >> putStrLn (runPrint $ unmain f6) - >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f6)) - >> putStrLn (runPrint $ unmain f7) - >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f7)) - >> putStrLn (runPrint $ unmain f7') - >> putStrLn (show $ interpret 100 <$> runCompiler (unmain f7')) +-- >> putStrLn (runPrint $ unmain f6) +-- >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f6)) +-- >> putStrLn (runPrint $ unmain f7) +-- >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f7)) +-- >> putStrLn (runPrint $ unmain f7') +-- >> putStrLn (show $ interpret 100 <$> runCompiler (unmain f7')) e0 :: Expression v => v Int e0 = lit 2 -. lit 8 @@ -94,8 +94,8 @@ f4 f5 :: (List' v, Expression v, Function (v (List Int)) v) => Main (v Int) f5 = fun ( \sumf->(\l->[cp|case l of - Cons e rest -> e +. sumf(rest) Nil -> 0 + Cons e rest -> e +. sumf(rest) |]) -- :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))} :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))} @@ -104,7 +104,7 @@ f5 f6 :: (TupleR' v, Expression v, Function (v (TupleR Int Char)) v) => Main (v Int) f6 = fun ( \firstfun->(\l->[cp|case l of - TupleR{first=f} -> f + TupleR {first=f} -> f |]) -- :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))} :- Main {unmain=firstfun $ tupler (lit 1) (lit 'c')} @@ -113,8 +113,8 @@ f6 f7 :: (Expression v, Function (v Int) v) => Main (v Int) f7 = fun ( \ffac->(\l->[cp|case l of - 0 -> 1; - n -> n *. ffac (n -. 1); + 0 -> 1 + n -> n *. ffac (n -. 1) |]) :- Main {unmain=ffac (lit 10)} ) -- 2.20.1