module Plugin.Pl.Parser (parsePF) where import Plugin.Pl.Common import qualified Language.Haskell.Exts as HSE todo :: (Functor e, Show (e ())) => e a -> r todo :: forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo e a thing = forall a. HasCallStack => [Char] -> a error ([Char] "pointfree: not supported: " forall a. [a] -> [a] -> [a] ++ forall a. Show a => a -> [Char] show (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a b. a -> b -> a const ()) e a thing)) nameString :: HSE.Name a -> (Fixity, String) nameString :: forall a. Name a -> (Fixity, [Char]) nameString (HSE.Ident a _ [Char] s) = (Fixity Pref, [Char] s) nameString (HSE.Symbol a _ [Char] s) = (Fixity Inf, [Char] s) qnameString :: HSE.QName a -> (Fixity, String) qnameString :: forall a. QName a -> (Fixity, [Char]) qnameString (HSE.Qual a _ ModuleName a m Name a n) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((forall a. Pretty a => a -> [Char] HSE.prettyPrint ModuleName a m forall a. [a] -> [a] -> [a] ++ [Char] ".") forall a. [a] -> [a] -> [a] ++) (forall a. Name a -> (Fixity, [Char]) nameString Name a n) qnameString (HSE.UnQual a _ Name a n) = forall a. Name a -> (Fixity, [Char]) nameString Name a n qnameString (HSE.Special a _ SpecialCon a sc) = case SpecialCon a sc of HSE.UnitCon a _ -> (Fixity Pref, [Char] "()") HSE.ListCon a _ -> (Fixity Pref, [Char] "[]") HSE.FunCon a _ -> (Fixity Inf, [Char] "->") HSE.TupleCon a _ Boxed HSE.Boxed Int n -> (Fixity Inf, forall a. Int -> a -> [a] replicate (Int nforall a. Num a => a -> a -> a -Int 1) Char ',') HSE.TupleCon{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo SpecialCon a sc HSE.Cons a _ -> (Fixity Inf, [Char] ":") HSE.UnboxedSingleCon{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo SpecialCon a sc HSE.ExprHole{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo SpecialCon a sc opString :: HSE.QOp a -> (Fixity, String) opString :: forall a. QOp a -> (Fixity, [Char]) opString (HSE.QVarOp a _ QName a qn) = forall a. QName a -> (Fixity, [Char]) qnameString QName a qn opString (HSE.QConOp a _ QName a qn) = forall a. QName a -> (Fixity, [Char]) qnameString QName a qn list :: [Expr] -> Expr list :: [Expr] -> Expr list = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\Expr y Expr ys -> Expr cons Expr -> Expr -> Expr `App` Expr y Expr -> Expr -> Expr `App` Expr ys) Expr nil hseToExpr :: HSE.Exp a -> Expr hseToExpr :: forall a. Exp a -> Expr hseToExpr Exp a expr = case Exp a expr of HSE.Var a _ QName a qn -> forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Fixity -> [Char] -> Expr Var (forall a. QName a -> (Fixity, [Char]) qnameString QName a qn) HSE.IPVar{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Exp a expr HSE.Con a _ QName a qn -> forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Fixity -> [Char] -> Expr Var (forall a. QName a -> (Fixity, [Char]) qnameString QName a qn) HSE.Lit a _ Literal a l -> case Literal a l of HSE.String a _ [Char] _ [Char] s -> [Expr] -> Expr list (forall a b. (a -> b) -> [a] -> [b] map (Fixity -> [Char] -> Expr Var Fixity Pref forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Show a => a -> [Char] show) [Char] s) Literal a _ -> Fixity -> [Char] -> Expr Var Fixity Pref (forall a. Pretty a => a -> [Char] HSE.prettyPrint Literal a l) HSE.InfixApp a _ Exp a p QOp a op Exp a q -> forall a. Expr -> [Exp a] -> Expr apps (Fixity -> [Char] -> Expr Var Fixity Inf (forall a b. (a, b) -> b snd (forall a. QOp a -> (Fixity, [Char]) opString QOp a op))) [Exp a p,Exp a q] HSE.App a _ Exp a f Exp a x -> forall a. Exp a -> Expr hseToExpr Exp a f Expr -> Expr -> Expr `App` forall a. Exp a -> Expr hseToExpr Exp a x HSE.NegApp a _ Exp a e -> Fixity -> [Char] -> Expr Var Fixity Pref [Char] "negate" Expr -> Expr -> Expr `App` forall a. Exp a -> Expr hseToExpr Exp a e HSE.Lambda a _ [Pat a] ps Exp a e -> forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (Pattern -> Expr -> Expr Lambda forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Pat a -> Pattern hseToPattern) (forall a. Exp a -> Expr hseToExpr Exp a e) [Pat a] ps HSE.Let a _ Binds a bs Exp a e -> case Binds a bs of HSE.BDecls a _ [Decl a] ds -> [Decl] -> Expr -> Expr Let (forall a b. (a -> b) -> [a] -> [b] map forall a. Decl a -> Decl hseToDecl [Decl a] ds) (forall a. Exp a -> Expr hseToExpr Exp a e) HSE.IPBinds a _ [IPBind a] ips -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo [IPBind a] ips HSE.If a _ Exp a b Exp a t Exp a f -> forall a. Expr -> [Exp a] -> Expr apps Expr if' [Exp a b,Exp a t,Exp a f] HSE.Case{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Exp a expr HSE.Do{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Exp a expr HSE.MDo{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Exp a expr HSE.Tuple a _ Boxed HSE.Boxed [Exp a] es -> forall a. Expr -> [Exp a] -> Expr apps (Fixity -> [Char] -> Expr Var Fixity Inf (forall a. Int -> a -> [a] replicate (forall (t :: * -> *) a. Foldable t => t a -> Int length [Exp a] es forall a. Num a => a -> a -> a - Int 1) Char ',')) [Exp a] es HSE.TupleSection{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Exp a expr HSE.List a _ [Exp a] xs -> [Expr] -> Expr list (forall a b. (a -> b) -> [a] -> [b] map forall a. Exp a -> Expr hseToExpr [Exp a] xs) HSE.Paren a _ Exp a e -> forall a. Exp a -> Expr hseToExpr Exp a e HSE.LeftSection a _ Exp a l QOp a op -> Fixity -> [Char] -> Expr Var Fixity Inf (forall a b. (a, b) -> b snd (forall a. QOp a -> (Fixity, [Char]) opString QOp a op)) Expr -> Expr -> Expr `App` forall a. Exp a -> Expr hseToExpr Exp a l HSE.RightSection a _ QOp a op Exp a r -> Expr flip' Expr -> Expr -> Expr `App` Fixity -> [Char] -> Expr Var Fixity Inf (forall a b. (a, b) -> b snd (forall a. QOp a -> (Fixity, [Char]) opString QOp a op)) Expr -> Expr -> Expr `App` forall a. Exp a -> Expr hseToExpr Exp a r HSE.RecConstr{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Exp a expr HSE.RecUpdate{} -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Exp a expr HSE.EnumFrom a _ Exp a x -> forall a. Expr -> [Exp a] -> Expr apps (Fixity -> [Char] -> Expr Var Fixity Pref [Char] "enumFrom") [Exp a x] HSE.EnumFromTo a _ Exp a x Exp a y -> forall a. Expr -> [Exp a] -> Expr apps (Fixity -> [Char] -> Expr Var Fixity Pref [Char] "enumFromTo") [Exp a x,Exp a y] HSE.EnumFromThen a _ Exp a x Exp a y -> forall a. Expr -> [Exp a] -> Expr apps (Fixity -> [Char] -> Expr Var Fixity Pref [Char] "enumFromThen") [Exp a x,Exp a y] HSE.EnumFromThenTo a _ Exp a x Exp a y Exp a z -> forall a. Expr -> [Exp a] -> Expr apps (Fixity -> [Char] -> Expr Var Fixity Pref [Char] "enumFromThenTo") [Exp a x,Exp a y,Exp a z] Exp a _ -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Exp a expr apps :: Expr -> [HSE.Exp a] -> Expr apps :: forall a. Expr -> [Exp a] -> Expr apps Expr f [Exp a] xs = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl (\Expr a Exp a x -> Expr a Expr -> Expr -> Expr `App` forall a. Exp a -> Expr hseToExpr Exp a x) Expr f [Exp a] xs hseToDecl :: HSE.Decl a -> Decl hseToDecl :: forall a. Decl a -> Decl hseToDecl Decl a dec = case Decl a dec of HSE.PatBind a _ (HSE.PVar a _ Name a n) (HSE.UnGuardedRhs a _ Exp a e) Maybe (Binds a) Nothing -> [Char] -> Expr -> Decl Define (forall a b. (a, b) -> b snd (forall a. Name a -> (Fixity, [Char]) nameString Name a n)) (forall a. Exp a -> Expr hseToExpr Exp a e) HSE.FunBind a _ [HSE.Match a _ Name a n [Pat a] ps (HSE.UnGuardedRhs a _ Exp a e) Maybe (Binds a) Nothing] -> [Char] -> Expr -> Decl Define (forall a b. (a, b) -> b snd (forall a. Name a -> (Fixity, [Char]) nameString Name a n)) (forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (\Pat a p Expr x -> Pattern -> Expr -> Expr Lambda (forall a. Pat a -> Pattern hseToPattern Pat a p) Expr x) (forall a. Exp a -> Expr hseToExpr Exp a e) [Pat a] ps) Decl a _ -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Decl a dec hseToPattern :: HSE.Pat a -> Pattern hseToPattern :: forall a. Pat a -> Pattern hseToPattern Pat a pat = case Pat a pat of HSE.PVar a _ Name a n -> [Char] -> Pattern PVar (forall a b. (a, b) -> b snd (forall a. Name a -> (Fixity, [Char]) nameString Name a n)) HSE.PInfixApp a _ Pat a l (HSE.Special a _ (HSE.Cons a _)) Pat a r -> Pattern -> Pattern -> Pattern PCons (forall a. Pat a -> Pattern hseToPattern Pat a l) (forall a. Pat a -> Pattern hseToPattern Pat a r) HSE.PTuple a _ Boxed HSE.Boxed [Pat a p,Pat a q] -> Pattern -> Pattern -> Pattern PTuple (forall a. Pat a -> Pattern hseToPattern Pat a p) (forall a. Pat a -> Pattern hseToPattern Pat a q) HSE.PParen a _ Pat a p -> forall a. Pat a -> Pattern hseToPattern Pat a p HSE.PWildCard a _ -> [Char] -> Pattern PVar [Char] "_" Pat a _ -> forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r todo Pat a pat parseMode :: HSE.ParseMode parseMode :: ParseMode parseMode = ParseMode HSE.defaultParseMode{ extensions :: [Extension] HSE.extensions = [KnownExtension -> Extension HSE.EnableExtension KnownExtension HSE.UnicodeSyntax] } parsePF :: String -> Either String TopLevel parsePF :: [Char] -> Either [Char] TopLevel parsePF [Char] inp = case ParseMode -> [Char] -> ParseResult (Exp SrcSpanInfo) HSE.parseExpWithMode ParseMode parseMode [Char] inp of HSE.ParseOk Exp SrcSpanInfo e -> forall a b. b -> Either a b Right (Expr -> TopLevel TLE (forall a. Exp a -> Expr hseToExpr Exp SrcSpanInfo e)) HSE.ParseFailed SrcLoc _ [Char] expParseErr -> case ParseMode -> [Char] -> ParseResult (Decl SrcSpanInfo) HSE.parseDeclWithMode ParseMode parseMode [Char] inp of HSE.ParseOk Decl SrcSpanInfo d -> forall a b. b -> Either a b Right (Bool -> Decl -> TopLevel TLD Bool True (forall a. Decl a -> Decl hseToDecl Decl SrcSpanInfo d)) HSE.ParseFailed SrcLoc _ [Char] declParseErr -> forall a b. a -> Either a b Left [Char] jointErrorMessage where jointErrorMessage :: [Char] jointErrorMessage = forall (m :: * -> *) a. Monad m => m (m a) -> m a join [ [Char] "Parsing input as an expression failed with \"", [Char] expParseErr, [Char] "\"" , [Char] "\n" , [Char] "Parsing input as an declaration failed with \"", [Char] declParseErr, [Char] "\"" ]