{-
 - Copyright 2024 Tycho Andersen
 -
 - This module exists as a small AST to replace language-python, which seems
 - largely unmaintained at this point. This is not really intended to be a
 - complete python grammer, mostly it is just enough to be what xcffib needs to
 - generate its trees.
 -
 - It has no annotations as in language-python, because xcffib doesn't use them.
 -
 - The grammar not complete: it cannot express anything other than empty
 - dictionaries, cannot express sets at all, cannot do async, etc. all because
 - these features of the language are unused by xcffib.
 -
 - The grammar is not sound: it has one "op" class, representing both unary and
 - binary operators.
 -
 - Use at your own risk :)
 -}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Data.XCB.Python.AST (
  Expr(..),
  Suite,
  Statement(..),
  Ident,
  Op(..),
  Pretty(..),
  prettyText,
  PseudoExpr(..)
) where

import Prelude hiding ((<>))

import Data.Maybe

import Text.PrettyPrint

type Suite = [Statement]

type Ident = String

-- we don't use that many operations :)
data Op
   = Plus
   | Minus
   | Multiply
   | FloorDivide
   | BinaryAnd
   | ShiftRight
   | ShiftLeft
   | Invert
   | Equality
   | LessThan
   | Modulo
   deriving (Op -> Op -> Bool
(Op -> Op -> Bool) -> (Op -> Op -> Bool) -> Eq Op
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Op -> Op -> Bool
== :: Op -> Op -> Bool
$c/= :: Op -> Op -> Bool
/= :: Op -> Op -> Bool
Eq, Eq Op
Eq Op =>
(Op -> Op -> Ordering)
-> (Op -> Op -> Bool)
-> (Op -> Op -> Bool)
-> (Op -> Op -> Bool)
-> (Op -> Op -> Bool)
-> (Op -> Op -> Op)
-> (Op -> Op -> Op)
-> Ord Op
Op -> Op -> Bool
Op -> Op -> Ordering
Op -> Op -> Op
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Op -> Op -> Ordering
compare :: Op -> Op -> Ordering
$c< :: Op -> Op -> Bool
< :: Op -> Op -> Bool
$c<= :: Op -> Op -> Bool
<= :: Op -> Op -> Bool
$c> :: Op -> Op -> Bool
> :: Op -> Op -> Bool
$c>= :: Op -> Op -> Bool
>= :: Op -> Op -> Bool
$cmax :: Op -> Op -> Op
max :: Op -> Op -> Op
$cmin :: Op -> Op -> Op
min :: Op -> Op -> Op
Ord, Int -> Op -> ShowS
[Op] -> ShowS
Op -> String
(Int -> Op -> ShowS)
-> (Op -> String) -> ([Op] -> ShowS) -> Show Op
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Op -> ShowS
showsPrec :: Int -> Op -> ShowS
$cshow :: Op -> String
show :: Op -> String
$cshowList :: [Op] -> ShowS
showList :: [Op] -> ShowS
Show)

data Statement
    = Import
      { Statement -> String
import_item :: Ident }
    -- this is only a one level dotted import; other levels are not supported
    | FromImport
      { Statement -> String
from_module :: Ident
      , Statement -> String
from_item :: Ident
      }
    -- we skip While, For, AsyncFor, etc. because we don't use them
    | Fun
      { Statement -> String
fun_name :: Ident
      -- only named variables, no default values, kwargs, etc.
      , Statement -> [String]
fun_args :: [Ident]
      , Statement -> Suite
fun_body :: Suite
      }
    | Decorated
      { Statement -> String
decorations :: Ident
      -- only decorated functions/methods are supported
      , fun_name :: Ident
      , fun_args :: [Ident]
      , fun_body :: Suite
      }
    -- skip AsyncFun...
    | Class
      { Statement -> String
class_name :: Ident
      -- same as functions, only identifiers allowed
      , Statement -> [String]
class_args :: [Ident]
      , Statement -> Suite
class_body :: Suite
      }
    | Conditional
      { Statement -> Expr
if_cond :: Expr
      , Statement -> Suite
if_body :: Suite
      , Statement -> Suite
else_body :: Suite
      }
    | Assign
      { Statement -> Expr
assign_to :: Expr
      , Statement -> Expr
assign_expr :: Expr
      }
    | AugmentedAssign
      { Statement -> Expr
aug_assign_to :: Expr
      , Statement -> Op
aug_assign_op :: Op
      , Statement -> Expr
aug_assign_expr :: Expr
      }
    -- skip AnnotatedAssign, Decorated
    | Return
      { Statement -> Maybe Expr
return_expr :: Maybe (Expr) }
    -- skip Try, With, AsyncWith
    | Pass {}
    -- skip Break, Continue, Delete
    | StmtExpr
      { Statement -> Expr
stmt_expr :: Expr }
    -- skip Global, NonLocal, Assert, Print, Exec
    | Raise { Statement -> String
raise_exception :: Ident }
    deriving (Statement -> Statement -> Bool
(Statement -> Statement -> Bool)
-> (Statement -> Statement -> Bool) -> Eq Statement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Statement -> Statement -> Bool
== :: Statement -> Statement -> Bool
$c/= :: Statement -> Statement -> Bool
/= :: Statement -> Statement -> Bool
Eq, Eq Statement
Eq Statement =>
(Statement -> Statement -> Ordering)
-> (Statement -> Statement -> Bool)
-> (Statement -> Statement -> Bool)
-> (Statement -> Statement -> Bool)
-> (Statement -> Statement -> Bool)
-> (Statement -> Statement -> Statement)
-> (Statement -> Statement -> Statement)
-> Ord Statement
Statement -> Statement -> Bool
Statement -> Statement -> Ordering
Statement -> Statement -> Statement
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Statement -> Statement -> Ordering
compare :: Statement -> Statement -> Ordering
$c< :: Statement -> Statement -> Bool
< :: Statement -> Statement -> Bool
$c<= :: Statement -> Statement -> Bool
<= :: Statement -> Statement -> Bool
$c> :: Statement -> Statement -> Bool
> :: Statement -> Statement -> Bool
$c>= :: Statement -> Statement -> Bool
>= :: Statement -> Statement -> Bool
$cmax :: Statement -> Statement -> Statement
max :: Statement -> Statement -> Statement
$cmin :: Statement -> Statement -> Statement
min :: Statement -> Statement -> Statement
Ord, Int -> Statement -> ShowS
Suite -> ShowS
Statement -> String
(Int -> Statement -> ShowS)
-> (Statement -> String) -> (Suite -> ShowS) -> Show Statement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Statement -> ShowS
showsPrec :: Int -> Statement -> ShowS
$cshow :: Statement -> String
show :: Statement -> String
$cshowList :: Suite -> ShowS
showList :: Suite -> ShowS
Show)

data Expr
    = Var { Expr -> String
var :: Ident }
    | Int { Expr -> Int
int_value :: Int }
    | Bool { Expr -> Bool
bool_value :: Bool }
    | None
    | Strings { Expr -> [String]
strings_strings :: [String] }
    | Call
      { Expr -> Expr
call_fun :: Expr
      , Expr -> [Expr]
call_args :: [Expr]
      }
    | CondExpr
      { Expr -> Expr
ce_true_branch :: Expr
      , Expr -> Expr
ce_conditon :: Expr
      , Expr -> Expr
ce_false_branch :: Expr
      }
    | Subscript
      { Expr -> Expr
subscriptee :: Expr
      , Expr -> Expr
subscript_expr :: Expr
      }
    | BinaryOp
      { Expr -> Op
operator :: Op
      , Expr -> Expr
binop_left :: Expr
      , Expr -> Expr
binop_right :: Expr
      }
    | UnaryOp
      { operator :: Op
      , Expr -> Expr
unop_arg :: Expr
      }
    | Dot
      { Expr -> Expr
dot_expr :: Expr
      , Expr -> String
dot_attribute :: Ident
      }
    | Tuple { Expr -> [Expr]
tuple_exprs :: [Expr] }
    | EmptyDict {} -- an empty dictionary
    | Paren { Expr -> Expr
paren_expr :: Expr }
    deriving (Expr -> Expr -> Bool
(Expr -> Expr -> Bool) -> (Expr -> Expr -> Bool) -> Eq Expr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
/= :: Expr -> Expr -> Bool
Eq, Eq Expr
Eq Expr =>
(Expr -> Expr -> Ordering)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Bool)
-> (Expr -> Expr -> Expr)
-> (Expr -> Expr -> Expr)
-> Ord Expr
Expr -> Expr -> Bool
Expr -> Expr -> Ordering
Expr -> Expr -> Expr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Expr -> Expr -> Ordering
compare :: Expr -> Expr -> Ordering
$c< :: Expr -> Expr -> Bool
< :: Expr -> Expr -> Bool
$c<= :: Expr -> Expr -> Bool
<= :: Expr -> Expr -> Bool
$c> :: Expr -> Expr -> Bool
> :: Expr -> Expr -> Bool
$c>= :: Expr -> Expr -> Bool
>= :: Expr -> Expr -> Bool
$cmax :: Expr -> Expr -> Expr
max :: Expr -> Expr -> Expr
$cmin :: Expr -> Expr -> Expr
min :: Expr -> Expr -> Expr
Ord, Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
(Int -> Expr -> ShowS)
-> (Expr -> String) -> ([Expr] -> ShowS) -> Show Expr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Expr -> ShowS
showsPrec :: Int -> Expr -> ShowS
$cshow :: Expr -> String
show :: Expr -> String
$cshowList :: [Expr] -> ShowS
showList :: [Expr] -> ShowS
Show)

prettyText :: Pretty a => a -> String
prettyText :: forall a. Pretty a => a -> String
prettyText = Doc -> String
render (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Pretty a => a -> Doc
pretty

class Pretty a where
    pretty :: a -> Doc

instance Pretty Op where
    pretty :: Op -> Doc
pretty Op
Plus = String -> Doc
text String
"+"
    pretty Op
Minus = String -> Doc
text String
"-"
    pretty Op
Multiply = String -> Doc
text String
"*"
    pretty Op
FloorDivide = String -> Doc
text String
"//"
    pretty Op
BinaryAnd = String -> Doc
text String
"&"
    pretty Op
ShiftRight = String -> Doc
text String
">>"
    pretty Op
ShiftLeft = String -> Doc
text String
"<<"
    pretty Op
Invert = String -> Doc
text String
"~"
    pretty Op
Equality = String -> Doc
text String
"=="
    pretty Op
LessThan = String -> Doc
text String
"<"
    pretty Op
Modulo = String -> Doc
text String
"%"

_reserved :: [String]
_reserved :: [String]
_reserved = [ String
"None"
            , String
"def"
            , String
"class"
            , String
"and"
            , String
"or"
            ]

-- | Sanitize identifiers.
instance Pretty Ident where
    pretty :: String -> Doc
pretty String
s | String
s String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
_reserved = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
    pretty String
s | String -> Bool
isInt String
s = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
      where
        isInt :: String -> Bool
isInt String
str = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ ((String -> Maybe Int
maybeRead String
str) :: Maybe Int)
        maybeRead :: String -> Maybe Int
maybeRead = ((Int, String) -> Int) -> Maybe (Int, String) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, String) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, String) -> Maybe Int)
-> (String -> Maybe (Int, String)) -> String -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, String)] -> Maybe (Int, String)
forall a. [a] -> Maybe a
listToMaybe ([(Int, String)] -> Maybe (Int, String))
-> (String -> [(Int, String)]) -> String -> Maybe (Int, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(Int, String)]
forall a. Read a => ReadS a
reads
    pretty String
s = String -> Doc
text String
s

instance Pretty Suite where
    pretty :: Suite -> Doc
pretty Suite
stmts = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Statement -> Doc) -> Suite -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Statement -> Doc
forall a. Pretty a => a -> Doc
pretty Suite
stmts

indent :: Doc -> Doc
indent :: Doc -> Doc
indent = Int -> Doc -> Doc
nest Int
4

instance Pretty Statement where
    pretty :: Statement -> Doc
pretty (Import String
item) = String -> Doc
text String
"import" Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pretty String
item
    pretty (FromImport String
source String
item) = String -> Doc
text String
"from" Doc -> Doc -> Doc
<+> String -> Doc
text String
source Doc -> Doc -> Doc
<+> String -> Doc
text String
"import" Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pretty String
item
    pretty (Fun String
name [String]
args Suite
bod) = String -> Doc
text String
"def" Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pretty String
name Doc -> Doc -> Doc
<> (Doc -> Doc
parens ([String] -> Doc
forall a. PseudoExpr a => [a] -> Doc
addCommas [String]
args)) Doc -> Doc -> Doc
<> Doc
colon
                                 Doc -> Doc -> Doc
$+$ Doc -> Doc
indent (Suite -> Doc
forall a. Pretty a => a -> Doc
pretty Suite
bod)
    pretty (Decorated String
decorator String
name [String]
args Suite
bod) = String -> Doc
text String
"@" Doc -> Doc -> Doc
<> String -> Doc
text String
decorator Doc -> Doc -> Doc
$+$ Statement -> Doc
forall a. Pretty a => a -> Doc
pretty (String -> [String] -> Suite -> Statement
Fun String
name [String]
args Suite
bod)
    pretty (Class String
name [] Suite
body) = String -> Doc
text String
"class" Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pretty String
name Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
$+$ Doc -> Doc
indent (Suite -> Doc
forall a. Pretty a => a -> Doc
pretty Suite
body)
    pretty (Class String
name [String]
superclasses Suite
body) = String -> Doc
text String
"class" Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pretty String
name Doc -> Doc -> Doc
<> Doc -> Doc
parens ([String] -> Doc
forall a. PseudoExpr a => [a] -> Doc
addCommas [String]
superclasses) Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
$+$ Doc -> Doc
indent (Suite -> Doc
forall a. Pretty a => a -> Doc
pretty Suite
body)
    pretty (Conditional Expr
cond Suite
if_ Suite
else_) = String -> Doc
text String
"if" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
cond Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
$+$ Doc -> Doc
indent (Suite -> Doc
forall a. Pretty a => a -> Doc
pretty Suite
if_) Doc -> Doc -> Doc
$+$ Suite -> Doc
forall a. Pretty a => a -> Doc
pretty Suite
else_
    pretty (Assign Expr
to Expr
expr) = Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
to Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
expr
    pretty (AugmentedAssign Expr
to Op
op Expr
expr) = Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
to Doc -> Doc -> Doc
<+> Op -> Doc
forall a. Pretty a => a -> Doc
pretty Op
op Doc -> Doc -> Doc
<> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
expr
    pretty (Return (Just Expr
expr)) = String -> Doc
text String
"return" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
expr
    pretty (Return Maybe Expr
Nothing) = String -> Doc
text String
"return"
    pretty Statement
Pass = String -> Doc
text String
"pass"
    pretty (StmtExpr Expr
expr) = Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
expr
    pretty (Raise String
exc) = String -> Doc
text String
"raise" Doc -> Doc -> Doc
<+> String -> Doc
forall a. Pretty a => a -> Doc
pretty String
exc

class PseudoExpr a where
  getExpr :: a -> Expr

instance PseudoExpr String where
  getExpr :: String -> Expr
getExpr String
s = String -> Expr
Var String
s
instance PseudoExpr Expr where
  getExpr :: Expr -> Expr
getExpr = Expr -> Expr
forall a. a -> a
id

addCommas :: PseudoExpr a => [a] -> Doc
addCommas :: forall a. PseudoExpr a => [a] -> Doc
addCommas [a]
exprs = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate (String -> Doc
text String
",") ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Expr -> Doc
forall a. Pretty a => a -> Doc
pretty (Expr -> Doc) -> (a -> Expr) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Expr
forall a. PseudoExpr a => a -> Expr
getExpr) [a]
exprs)

instance Pretty Expr where
    pretty :: Expr -> Doc
pretty (Var String
v) = String -> Doc
forall a. Pretty a => a -> Doc
pretty String
v
    pretty (Int Int
i) = Integer -> Doc
integer (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
i)
    pretty (Bool Bool
True) = String -> Doc
text String
"True"
    pretty (Bool Bool
False) = String -> Doc
text String
"False"
    pretty Expr
None = String -> Doc
text String
"None"
    pretty (Strings [String]
xs) = [Doc] -> Doc
hcat ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
xs)
    pretty (Call Expr
fun [Expr]
args) = Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
fun Doc -> Doc -> Doc
<> Doc
lparen Doc -> Doc -> Doc
<> [Expr] -> Doc
forall a. PseudoExpr a => [a] -> Doc
addCommas [Expr]
args Doc -> Doc -> Doc
<> Doc
rparen
    pretty (CondExpr Expr
trueB Expr
cond Expr
falseB) = Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
trueB Doc -> Doc -> Doc
<+> String -> Doc
text String
"if" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
cond Doc -> Doc -> Doc
<+> String -> Doc
text String
"else" Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
falseB
    pretty (Subscript Expr
thing Expr
expr) = Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
thing Doc -> Doc -> Doc
<> Doc -> Doc
brackets (Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
expr)
    pretty (BinaryOp Op
op Expr
left Expr
right) = Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
left Doc -> Doc -> Doc
<+> Op -> Doc
forall a. Pretty a => a -> Doc
pretty Op
op Doc -> Doc -> Doc
<+> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
right
    pretty (UnaryOp Op
op Expr
arg) = Op -> Doc
forall a. Pretty a => a -> Doc
pretty Op
op Doc -> Doc -> Doc
<> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
arg
    pretty (Dot Expr
thing String
attr) = Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
thing Doc -> Doc -> Doc
<> String -> Doc
text String
"." Doc -> Doc -> Doc
<> String -> Doc
forall a. Pretty a => a -> Doc
pretty String
attr
    pretty (Tuple [Expr
expr]) = Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
expr Doc -> Doc -> Doc
<> Doc
comma -- one element still needs to be a tuple
    pretty (Tuple [Expr]
exprs) = [Expr] -> Doc
forall a. PseudoExpr a => [a] -> Doc
addCommas [Expr]
exprs
    pretty Expr
EmptyDict = String -> Doc
text String
"{}"
    pretty (Paren Expr
expr) = Doc
lparen Doc -> Doc -> Doc
<> Expr -> Doc
forall a. Pretty a => a -> Doc
pretty Expr
expr Doc -> Doc -> Doc
<> Doc
rparen