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]
"\""
        ]