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 :: e a -> r
todo e a
thing = [Char] -> r
forall a. HasCallStack => [Char] -> a
error ([Char]
"pointfree: not supported: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ e () -> [Char]
forall a. Show a => a -> [Char]
show ((a -> ()) -> e a -> e ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> a -> ()
forall a b. a -> b -> a
const ()) e a
thing))

nameString :: HSE.Name a -> (Fixity, String)
nameString :: 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 :: QName a -> (Fixity, [Char])
qnameString (HSE.Qual a
_ ModuleName a
m Name a
n) = ([Char] -> [Char]) -> (Fixity, [Char]) -> (Fixity, [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ModuleName a -> [Char]
forall a. Pretty a => a -> [Char]
HSE.prettyPrint ModuleName a
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) (Name a -> (Fixity, [Char])
forall a. Name a -> (Fixity, [Char])
nameString Name a
n)
qnameString (HSE.UnQual a
_ Name a
n) = Name a -> (Fixity, [Char])
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, Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',')
  HSE.TupleCon{} -> SpecialCon a -> (Fixity, [Char])
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo SpecialCon a
sc
  HSE.Cons a
_ -> (Fixity
Inf, [Char]
":")
  HSE.UnboxedSingleCon{} -> SpecialCon a -> (Fixity, [Char])
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo SpecialCon a
sc
  HSE.ExprHole{} -> SpecialCon a -> (Fixity, [Char])
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo SpecialCon a
sc

opString :: HSE.QOp a -> (Fixity, String)
opString :: QOp a -> (Fixity, [Char])
opString (HSE.QVarOp a
_ QName a
qn) = QName a -> (Fixity, [Char])
forall a. QName a -> (Fixity, [Char])
qnameString QName a
qn
opString (HSE.QConOp a
_ QName a
qn) = QName a -> (Fixity, [Char])
forall a. QName a -> (Fixity, [Char])
qnameString QName a
qn

list :: [Expr] -> Expr
list :: [Expr] -> Expr
list = (Expr -> Expr -> Expr) -> Expr -> [Expr] -> Expr
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 :: Exp a -> Expr
hseToExpr Exp a
expr = case Exp a
expr of
  HSE.Var a
_ QName a
qn -> (Fixity -> [Char] -> Expr) -> (Fixity, [Char]) -> Expr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Fixity -> [Char] -> Expr
Var (QName a -> (Fixity, [Char])
forall a. QName a -> (Fixity, [Char])
qnameString QName a
qn)
  HSE.IPVar{} -> Exp a -> Expr
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo Exp a
expr
  HSE.Con a
_ QName a
qn -> (Fixity -> [Char] -> Expr) -> (Fixity, [Char]) -> Expr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Fixity -> [Char] -> Expr
Var (QName a -> (Fixity, [Char])
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 ((Char -> Expr) -> [Char] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Fixity -> [Char] -> Expr
Var Fixity
Pref ([Char] -> Expr) -> (Char -> [Char]) -> Char -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> [Char]
forall a. Show a => a -> [Char]
show) [Char]
s)
    Literal a
_ -> Fixity -> [Char] -> Expr
Var Fixity
Pref (Literal a -> [Char]
forall a. Pretty a => a -> [Char]
HSE.prettyPrint Literal a
l)
  HSE.InfixApp a
_ Exp a
p QOp a
op Exp a
q -> Expr -> [Exp a] -> Expr
forall a. Expr -> [Exp a] -> Expr
apps (Fixity -> [Char] -> Expr
Var Fixity
Inf ((Fixity, [Char]) -> [Char]
forall a b. (a, b) -> b
snd (QOp a -> (Fixity, [Char])
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 -> Exp a -> Expr
forall a. Exp a -> Expr
hseToExpr Exp a
f Expr -> Expr -> Expr
`App` Exp a -> Expr
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` Exp a -> Expr
forall a. Exp a -> Expr
hseToExpr Exp a
e
  HSE.Lambda a
_ [Pat a]
ps Exp a
e -> (Pat a -> Expr -> Expr) -> Expr -> [Pat a] -> Expr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Pattern -> Expr -> Expr
Lambda (Pattern -> Expr -> Expr)
-> (Pat a -> Pattern) -> Pat a -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat a -> Pattern
forall a. Pat a -> Pattern
hseToPattern) (Exp a -> Expr
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 ((Decl a -> Decl) -> [Decl a] -> [Decl]
forall a b. (a -> b) -> [a] -> [b]
map Decl a -> Decl
forall a. Decl a -> Decl
hseToDecl [Decl a]
ds) (Exp a -> Expr
forall a. Exp a -> Expr
hseToExpr Exp a
e)
    HSE.IPBinds a
_ [IPBind a]
ips -> [IPBind a] -> Expr
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 -> Expr -> [Exp a] -> Expr
forall a. Expr -> [Exp a] -> Expr
apps Expr
if' [Exp a
b,Exp a
t,Exp a
f]
  HSE.Case{} -> Exp a -> Expr
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo Exp a
expr
  HSE.Do{} -> Exp a -> Expr
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo Exp a
expr
  HSE.MDo{} -> Exp a -> Expr
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo Exp a
expr
  HSE.Tuple a
_ Boxed
HSE.Boxed [Exp a]
es -> Expr -> [Exp a] -> Expr
forall a. Expr -> [Exp a] -> Expr
apps (Fixity -> [Char] -> Expr
Var Fixity
Inf (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([Exp a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp a]
es Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
','))  [Exp a]
es
  HSE.TupleSection{} -> Exp a -> Expr
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo Exp a
expr
  HSE.List a
_ [Exp a]
xs -> [Expr] -> Expr
list ((Exp a -> Expr) -> [Exp a] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Exp a -> Expr
forall a. Exp a -> Expr
hseToExpr [Exp a]
xs)
  HSE.Paren a
_ Exp a
e -> Exp a -> Expr
forall a. Exp a -> Expr
hseToExpr Exp a
e
  HSE.LeftSection a
_ Exp a
l QOp a
op -> Fixity -> [Char] -> Expr
Var Fixity
Inf ((Fixity, [Char]) -> [Char]
forall a b. (a, b) -> b
snd (QOp a -> (Fixity, [Char])
forall a. QOp a -> (Fixity, [Char])
opString QOp a
op)) Expr -> Expr -> Expr
`App` Exp a -> Expr
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 ((Fixity, [Char]) -> [Char]
forall a b. (a, b) -> b
snd (QOp a -> (Fixity, [Char])
forall a. QOp a -> (Fixity, [Char])
opString QOp a
op)) Expr -> Expr -> Expr
`App` Exp a -> Expr
forall a. Exp a -> Expr
hseToExpr Exp a
r
  HSE.RecConstr{} -> Exp a -> Expr
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo Exp a
expr
  HSE.RecUpdate{} -> Exp a -> Expr
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo Exp a
expr
  HSE.EnumFrom a
_ Exp a
x -> Expr -> [Exp a] -> Expr
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 -> Expr -> [Exp a] -> Expr
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 -> Expr -> [Exp a] -> Expr
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 -> Expr -> [Exp a] -> Expr
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
_ -> Exp a -> Expr
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo Exp a
expr

apps :: Expr -> [HSE.Exp a] -> Expr
apps :: Expr -> [Exp a] -> Expr
apps Expr
f [Exp a]
xs = (Expr -> Exp a -> Expr) -> Expr -> [Exp a] -> Expr
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` Exp a -> Expr
forall a. Exp a -> Expr
hseToExpr Exp a
x) Expr
f [Exp a]
xs 

hseToDecl :: HSE.Decl a -> Decl
hseToDecl :: 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 ((Fixity, [Char]) -> [Char]
forall a b. (a, b) -> b
snd (Name a -> (Fixity, [Char])
forall a. Name a -> (Fixity, [Char])
nameString Name a
n)) (Exp a -> Expr
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 ((Fixity, [Char]) -> [Char]
forall a b. (a, b) -> b
snd (Name a -> (Fixity, [Char])
forall a. Name a -> (Fixity, [Char])
nameString Name a
n)) ((Pat a -> Expr -> Expr) -> Expr -> [Pat a] -> Expr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Pat a
p Expr
x -> Pattern -> Expr -> Expr
Lambda (Pat a -> Pattern
forall a. Pat a -> Pattern
hseToPattern Pat a
p) Expr
x) (Exp a -> Expr
forall a. Exp a -> Expr
hseToExpr Exp a
e) [Pat a]
ps)
  Decl a
_ -> Decl a -> Decl
forall (e :: * -> *) a r. (Functor e, Show (e ())) => e a -> r
todo Decl a
dec

hseToPattern :: HSE.Pat a -> Pattern
hseToPattern :: Pat a -> Pattern
hseToPattern Pat a
pat = case Pat a
pat of
  HSE.PVar a
_ Name a
n -> [Char] -> Pattern
PVar ((Fixity, [Char]) -> [Char]
forall a b. (a, b) -> b
snd (Name a -> (Fixity, [Char])
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 (Pat a -> Pattern
forall a. Pat a -> Pattern
hseToPattern Pat a
l) (Pat a -> Pattern
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 (Pat a -> Pattern
forall a. Pat a -> Pattern
hseToPattern Pat a
p) (Pat a -> Pattern
forall a. Pat a -> Pattern
hseToPattern Pat a
q)
  HSE.PParen a
_ Pat a
p -> Pat a -> Pattern
forall a. Pat a -> Pattern
hseToPattern Pat a
p
  HSE.PWildCard a
_ -> [Char] -> Pattern
PVar [Char]
"_"
  Pat a
_ -> Pat a -> Pattern
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 -> TopLevel -> Either [Char] TopLevel
forall a b. b -> Either a b
Right (Expr -> TopLevel
TLE (Exp SrcSpanInfo -> Expr
forall a. Exp a -> Expr
hseToExpr Exp SrcSpanInfo
e))
  HSE.ParseFailed SrcLoc
_ [Char]
_ -> case ParseMode -> [Char] -> ParseResult (Decl SrcSpanInfo)
HSE.parseDeclWithMode ParseMode
parseMode [Char]
inp of
    HSE.ParseOk Decl SrcSpanInfo
d -> TopLevel -> Either [Char] TopLevel
forall a b. b -> Either a b
Right (Bool -> Decl -> TopLevel
TLD Bool
True (Decl SrcSpanInfo -> Decl
forall a. Decl a -> Decl
hseToDecl Decl SrcSpanInfo
d))
    HSE.ParseFailed SrcLoc
_ [Char]
err -> [Char] -> Either [Char] TopLevel
forall a b. a -> Either a b
Left [Char]
err