{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
{-# language LambdaCase #-}
{-# language RankNTypes #-}
{-# language RecordWildCards #-}
{-# language TemplateHaskell #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
module Language.Python.DSL
( (&)
, Raw
, Module
, Statement
, Expr
, module_
, blank_
, AsLine(..)
, Line(..)
, id_
, Ident(..)
, identAnn
, identValue
, identWhitespace
, StarSyntax(..)
, star_
, DoubleStarSyntax(..)
, As(..)
, IfSyntax(..)
, ForSyntax(..)
, InSyntax(..), In(..), InList(..)
, ColonSyntax(..)
, comp_
, Guard(..)
, Param(..)
, ParametersSyntax(..)
, Arg(..)
, ArgumentsSyntax(..)
, PositionalSyntax(..)
, PositionalParam(..)
, _PositionalParam
, ppAnn
, ppName
, ppType
, KeywordSyntax(..)
, KeywordParam(..)
, _KeywordParam
, kpAnn
, kpName
, kpType
, kpEquals
, kpExpr
, decorated_
, DecoratorsSyntax(..)
, AsyncSyntax(..)
, BodySyntax(..)
, def_
, Fundef(..)
, mkFundef
, fdAnn
, fdDecorators
, fdIndents
, fdAsync
, fdDefSpaces
, fdName
, fdLeftParenSpaces
, fdParameters
, fdRightParenSpaces
, fdReturnType
, fdBody
, class_
, ClassDef(..)
, mkClassDef
, cdAnn
, cdDecorators
, cdIndents
, cdClass
, cdName
, cdArguments
, cdBody
, chainEq
, (.=)
, (.+=)
, (.-=)
, (.*=)
, (.@=)
, (./=)
, (.%=)
, (.&=)
, (.|=)
, (.^=)
, (.<<=)
, (.>>=)
, (.**=)
, (.//=)
, tryE_
, tryF_
, ExceptSyntax(..)
, FinallySyntax(..)
, TryExcept(..)
, mkTryExcept
, TryFinally(..)
, mkTryFinally
, ExceptAs(..)
, AsExceptAs(..)
, Except(..)
, mkExcept
, Finally(..)
, mkFinally
, teAnn
, teIndents
, teTry
, teBody
, teExcepts
, teElse
, teFinally
, exceptIndents
, exceptExcept
, exceptExceptAs
, exceptBody
, finallyIndents
, finallyFinally
, finallyBody
, with_
, withItem_
, With(..)
, mkWith
, AsWithItem(..)
, WithItem(..)
, withAnn
, withIndents
, withAsync
, withWith
, withItems
, withBody
, else_
, ElseSyntax(..)
, break_
, forSt_
, For(..)
, _For
, mkFor
, ifThen_
, elif_
, If(..)
, mkIf
, Elif(..)
, mkElif
, Else(..)
, mkElse
, ifAnn
, ifIndents
, ifIf
, ifCond
, ifBody
, ifElifs
, ifElse
, elifIndents
, elifElif
, elifCond
, elifBody
, elseIndents
, elseElse
, elseBody
, pass_
, return_
, while_
, While(..)
, mkWhile
, whileAnn
, whileIndents
, whileWhile
, whileCond
, whileBody
, expr_
, var_
, await_
, ifThenElse_
, gen_
, yield_
, yieldFrom_
, tuple_
, Tuple(..)
, AsTupleItem(..)
, TupleItem()
, call_
, Call(..)
, mkCall
, callAnn
, callFunction
, callLeftParen
, callArguments
, callRightParen
, none_
, None(..)
, _None
, noneAnn
, noneWhitespace
, str_
, str'_
, longStr_
, longStr'_
, int_
, true_
, false_
, ellipsis_
, AsList(..)
, AsListItem(..)
, ListItem()
, AsDict(..)
, DictItem()
, AsSet(..)
, AsSetItem(..)
, SetItem()
, lambda_
, subs_
, sliceF_
, sliceFS_
, sliceT_
, sliceTS_
, sliceFT_
, sliceFTS_
, sliceS_
, fullSlice_
, slice_
, (/>)
, not_
, neg_
, pos_
, compl_
, or_
, and_
, is_
, isNot_
, notIn_
, (.==)
, (.>)
, (.>=)
, (.<)
, (.<=)
, (.!=)
, (.|)
, (.^)
, (.&)
, (.<<)
, (.>>)
, (.-)
, (.+)
, (.*)
, (.@)
, (./)
, (.//)
, (.%)
, (.**)
, linesToBlock
, blockToLines
)
where
import Control.Applicative ((<|>))
import Control.Lens.Fold ((^..), (^?), folded, lengthOf)
import Control.Lens.Getter ((^.), to)
import Control.Lens.Iso (from)
import Control.Lens.Lens (Lens')
import Control.Lens.Prism (_Right, _Just)
import Control.Lens.Review ((#))
import Control.Lens.Setter ((.~), (<>~), (?~), (%~), Setter', set, over, mapped)
import Control.Lens.TH (makeWrapped)
import Control.Lens.Traversal (Traversal', traverseOf)
import Control.Lens.Tuple (_2)
import Control.Lens.Wrapped (_Wrapped)
import Data.Foldable (toList)
import Data.Function ((&))
import Data.String (fromString)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (fromMaybe)
import Data.Semigroup ((<>))
import Language.Python.Optics
import Language.Python.Syntax.Ann
import Language.Python.Syntax.AugAssign
import Language.Python.Syntax.CommaSep
import Language.Python.Syntax.Expr
import Language.Python.Syntax.Ident
import Language.Python.Syntax.Module
import Language.Python.Syntax.Operator.Binary
import Language.Python.Syntax.Operator.Unary
import Language.Python.Syntax.Punctuation
import Language.Python.Syntax.Raw
import Language.Python.Syntax.Statement
import Language.Python.Syntax.Strings
import Language.Python.Syntax.Types
import Language.Python.Syntax.Whitespace
id_ :: String -> Raw Ident
id_ = fromString
module_ :: [Raw Line] -> Raw Module
module_ [] = ModuleEmpty
module_ (a:as) =
case unLine a of
Left (bl, nl) -> ModuleBlank bl nl $ module_ as
Right a -> ModuleStatement a $ module_ as
newtype Line v a
= Line
{ unLine :: Either (Blank a, Newline) (Statement v a)
} deriving (Eq, Show)
makeWrapped ''Line
blank_ :: Raw Line
blank_ = Line $ Left (Blank (Ann ()) [] Nothing, LF)
class AsLine s where
line_ :: Raw s -> Raw Line
instance AsLine SmallStatement where
line_ ss =
Line . Right $ SmallStatement (Indents [] (Ann ())) ss
instance AsLine SimpleStatement where
line_ ss =
Line . Right . SmallStatement (Indents [] (Ann ())) $
MkSmallStatement ss [] Nothing Nothing (Just LF)
instance AsLine CompoundStatement where
line_ = Line . Right . CompoundStatement
instance AsLine ClassDef where
line_ = line_ @Statement . (_ClassDef #)
instance AsLine Fundef where
line_ = line_ @Statement . (_Fundef #)
instance AsLine If where
line_ = line_ @Statement . (_If #)
instance AsLine While where
line_ = line_ @Statement . (_While #)
instance AsLine With where
line_ = line_ @Statement . (_With #)
instance AsLine Statement where
line_ = Line . Right
instance AsLine Expr where
line_ e = line_ $ Expr (e ^. annot) e
instance HasExprs Line where
_Exprs f (Line a) = Line <$> (_Right._Exprs) f a
instance HasStatements Line where
_Statements f (Line a) = Line <$> _Right f a
class BodySyntax s where
body_ :: Functor f => ([Raw Line] -> f [Raw Line]) -> Raw s -> f (Raw s)
body :: Lens' (Raw s) (Raw Suite)
class ColonSyntax s t | s -> t, t -> s where
(.:) :: Raw s -> Raw Expr -> Raw t
infix 0 .:
instance ColonSyntax Expr DictItem where
(.:) a = DictItem (Ann ()) a (MkColon [Space])
instance ColonSyntax Param Param where
(.:) p t = p & paramType_ ?~ (MkColon [Space], t)
class PositionalSyntax p v | p -> v, v -> p where
p_ :: Raw v -> Raw p
instance StarSyntax Ident Param where
s_ i = StarParam (Ann ()) [] i Nothing
instance DoubleStarSyntax Ident Param where
ss_ i = DoubleStarParam (Ann ()) [] i Nothing
class StarSyntax s t | t -> s where
s_ :: Raw s -> Raw t
instance StarSyntax Expr Arg where
s_ = StarArg (Ann ()) []
instance DoubleStarSyntax Expr Arg where
ss_ = DoubleStarArg (Ann ()) []
class KeywordSyntax p where
k_ :: Raw Ident -> Raw Expr -> Raw p
star_ :: Raw Param
star_ = UnnamedStarParam (Ann ()) []
class DoubleStarSyntax s t | t -> s where
ss_ :: Raw s -> Raw t
instance DoubleStarSyntax Expr DictItem where
ss_ = DictUnpack (Ann ()) []
instance PositionalSyntax Param Ident where
p_ i = PositionalParam (Ann ()) i Nothing
instance KeywordSyntax Param where
k_ a = KeywordParam (Ann ()) a Nothing []
instance PositionalSyntax Arg Expr where; p_ = PositionalArg (Ann ())
instance KeywordSyntax Arg where; k_ a = KeywordArg (Ann ()) a []
class ParametersSyntax s where
parameters_ :: Functor f => ([Raw Param] -> f [Raw Param]) -> Raw s -> f (Raw s)
parameters :: Lens' (Raw s) (CommaSep (Raw Param))
class ArgumentsSyntax s where
setArguments :: [Raw Arg] -> Raw s -> Raw s
getArguments :: Raw s -> [Raw Arg]
class DecoratorsSyntax s where
setDecorators :: [Raw Expr] -> Raw s -> Raw s
getDecorators :: Raw s -> [Raw Expr]
decorators :: Lens' (Raw s) [Raw Decorator]
decorated_ :: DecoratorsSyntax s => [Raw Expr] -> Raw s -> Raw s
decorated_ = setDecorators
exprsToDecorators :: Indents () -> [Raw Expr] -> [Raw Decorator]
exprsToDecorators is = fmap (\e -> Decorator (Ann ()) is (MkAt []) e Nothing LF [])
instance DecoratorsSyntax Fundef where
decorators = fdDecorators
setDecorators new code =
code
{ _fdDecorators = exprsToDecorators (_fdIndents code) new
}
getDecorators code = code ^.. fdDecorators.folded._Exprs
blockToLines :: Raw Block -> [Raw Line]
blockToLines (Block x y z) = fmap (Line . Left) x <> (Line (Right y) : fmap Line z)
mkBody_
:: Traversal' (Raw s) (Indents ())
-> Lens' (Raw s) (Raw Suite)
-> forall f. Functor f => ([Raw Line] -> f [Raw Line]) -> Raw s -> f (Raw s)
mkBody_ gIndents gBody f e =
(\ls -> e & gBody._Blocks .~ mkNewBlock allIndents ls id) <$> blLines'
where
defaultIndent =
fromMaybe
(Indents [replicate 4 Space ^. from indentWhitespaces] (Ann ()))
(e ^? gIndents)
numChunks = lengthOf (indentsValue.folded) defaultIndent + 1
blLines = e ^.. gBody._Blocks.to blockToLines.folded
blLines' =
f $
over
(mapped._Wrapped._Right._Indents.indentsValue)
(drop numChunks)
blLines
defaultNewIndent :: Indents (); allIndents :: [Indents ()]
(defaultNewIndent, allIndents) =
foldr
(\a (di, as) ->
maybe
(di, di : as)
(\x -> (x, x : as))
(a ^? to unLine._Right._Indents.to (indentsValue %~ take numChunks)))
(defaultIndent, [])
blLines
mkNewBlock
:: [Indents ()]
-> [Raw Line]
-> (Raw Block -> Raw Block)
-> Raw Block
mkNewBlock [] [] k =
k $ Block [] (pass_ & _Indents %~ (defaultNewIndent <>)) []
mkNewBlock (a:_) [] k =
k $ Block [] (pass_ & _Indents %~ (a <>)) []
mkNewBlock [] [b] k =
k $
either
(\w -> Block [w] (pass_ & _Indents %~ (defaultNewIndent <>)) [])
(\w -> Block [] (w & _Indents %~ (defaultNewIndent <>)) [])
(unLine b)
mkNewBlock (a:_) [b] k =
k $
either
(\w -> Block [w] (pass_ & _Indents %~ (a <>)) [])
(\w -> Block [] (w & _Indents %~ (a <>)) [])
(unLine b)
mkNewBlock [] (b:bs) k =
mkNewBlock [] bs $
\(Block x y z) ->
k $
either
(\w -> Block (w:x) y z)
(\w ->
Block []
(w & _Indents %~ (defaultNewIndent <>))
((Left <$> x) <> (Right y:z)))
(unLine b)
mkNewBlock (a:as) (b:bs) k =
mkNewBlock as bs $
\(Block x y z) ->
k $
either
(\w -> Block (w:x) y z)
(\w ->
Block []
(w & _Indents %~ (a <>))
((Left <$> x) <> (Right y:z)))
(unLine b)
instance BodySyntax Fundef where
body = fdBody
body_ = mkBody_ fdIndents fdBody
instance ParametersSyntax Fundef where
parameters_ f e = flip (set fdParameters) e . go ps <$> ps'
where
ps = e ^. fdParameters
ps' = f $ toList ps
go :: CommaSep (Raw Param) -> [Raw Param] -> CommaSep (Raw Param)
go CommaSepNone [] = CommaSepNone
go CommaSepNone (x:xs) = listToCommaSep $ x:xs
go CommaSepOne{} [] = CommaSepNone
go (CommaSepOne a) [x] =
CommaSepOne $ x & trailingWhitespace .~ (a ^. trailingWhitespace)
go (CommaSepOne a) (x:xs) =
listToCommaSep $ (x & trailingWhitespace .~ (a ^. trailingWhitespace)) :xs
go CommaSepMany{} [] = CommaSepNone
go (CommaSepMany a b c) (x:xs) =
CommaSepMany (x & trailingWhitespace .~ (a ^. trailingWhitespace)) b $ go c xs
parameters = fdParameters
mkFundef :: Raw Ident -> [Raw Line] -> Raw Fundef
mkFundef name body =
MkFundef
{ _fdAnn = Ann ()
, _fdDecorators = []
, _fdIndents = Indents [] (Ann ())
, _fdAsync = Nothing
, _fdDefSpaces = pure Space
, _fdName = name
, _fdLeftParenSpaces = []
, _fdParameters = CommaSepNone
, _fdRightParenSpaces = []
, _fdReturnType = Nothing
, _fdBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
}
def_ :: Raw Ident -> [Raw Param] -> [Raw Line] -> Raw Fundef
def_ name params body = (mkFundef name body) { _fdParameters = listToCommaSep params }
mkCall :: Raw Expr -> Raw Call
mkCall e =
MkCall
{ _callAnn = Ann ()
, _callFunction = e
, _callLeftParen = []
, _callArguments = Nothing
, _callRightParen = []
}
instance ArgumentsSyntax Call where
setArguments args code =
code
{ _callArguments =
case args of
[] -> Nothing
a:as -> Just $ (a, zip (repeat (MkComma [Space])) as, Nothing) ^. _CommaSep1'
}
getArguments code = _callArguments code ^.. folded.folded
call_ :: Raw Expr -> [Raw Arg] -> Raw Expr
call_ expr args =
_Call #
(mkCall expr)
{ _callArguments =
case args of
[] -> Nothing
a:as -> Just $ (a, zip (repeat (MkComma [Space])) as, Nothing) ^. _CommaSep1'
}
return_ :: Raw Expr -> Raw Statement
return_ e =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement (Return (Ann ()) [Space] $ Just e) [] Nothing Nothing (Just LF))
expr_ :: Raw Expr -> Raw Statement
expr_ e =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement (Expr (Ann ()) e) [] Nothing Nothing (Just LF))
class AsList s where
list_ :: s -> Raw Expr
class AsListItem s where
li_ :: Raw s -> Raw ListItem
instance AsListItem ListItem where
li_ = id
instance AsListItem Expr where
li_ = ListItem (Ann ())
instance StarSyntax Expr ListItem where
s_ = ListUnpack (Ann ()) [] []
instance e ~ Raw ListItem => AsList [e] where
list_ es = List (Ann ()) [] (listToCommaSep1' es) []
instance e ~ Comprehension Expr => AsList (Raw e) where
list_ c = ListComp (Ann ()) [] c []
newtype Guard v a = MkGuard { unGuard :: Either (CompFor v a) (CompIf v a) }
class ForSyntax a x | a -> x where
for_ :: Raw x -> a
instance ForSyntax (Raw CompFor) In where
for_ (MkIn a b) = CompFor (Ann ()) [Space] a [Space] b
instance ForSyntax (Raw Guard) In where
for_ (MkIn a b) = MkGuard . Left $ CompFor (Ann ()) [Space] a [Space] b
class IfSyntax a where
if_ :: Raw Expr -> a
instance IfSyntax (Raw Guard) where
if_ = MkGuard . Right . CompIf (Ann ()) [Space]
class AsSet s where
set_ :: s -> Raw Expr
class AsSetItem s where
si_ :: Raw s -> Raw SetItem
instance AsSetItem SetItem where
si_ = id
instance AsSetItem Expr where
si_ = SetItem (Ann ())
instance StarSyntax Expr SetItem where
s_ = SetUnpack (Ann ()) [] []
instance e ~ Raw SetItem => AsSet [e] where
set_ es =
case es of
[] -> call_ (var_ "set") []
a:as -> Set (Ann ()) [] ((a, zip (repeat (MkComma [Space])) as, Nothing) ^. _CommaSep1') []
instance e ~ Comprehension SetItem => AsSet (Raw e) where
set_ c = SetComp (Ann ()) [] c []
comp_ :: Raw e -> Raw CompFor -> [Raw Guard] -> Raw (Comprehension e)
comp_ val cfor guards =
Comprehension (Ann ())
val
(if null guards
then cfor
else cfor & trailingWhitespace .~ [Space])
(unGuard <$> guards)
gen_ :: Raw (Comprehension Expr) -> Raw Expr
gen_ = Generator (Ann ())
class AsDict s where
dict_ :: s -> Raw Expr
instance e ~ Raw DictItem => AsDict [e] where
dict_ ds =
Dict (Ann ())
[]
(case ds of
[] -> Nothing
a:as -> Just $ (a, zip (repeat (MkComma [Space])) as, Nothing) ^. _CommaSep1')
[]
instance e ~ Comprehension DictItem => AsDict (Raw e) where
dict_ comp = DictComp (Ann ()) [] comp []
mkBinOp :: ([Whitespace] -> BinOp ()) -> Raw Expr -> Raw Expr -> Raw Expr
mkBinOp bop a = BinOp (Ann ()) (a & trailingWhitespace .~ [Space]) (bop [Space])
is_ :: Raw Expr -> Raw Expr -> Raw Expr
is_ = mkBinOp $ Is (Ann ())
infixl 1 `is_`
data In v a = MkIn (Expr v a) (Expr v a)
data InList v a = MkInList (Expr v a) [Expr v a]
class InSyntax a x | a -> x, x -> a where
in_ :: Raw Expr -> x -> Raw a
infixl 1 `in_`
and_ :: Raw Expr -> Raw Expr -> Raw Expr
and_ a = BinOp (Ann ()) (a & trailingWhitespace .~ [Space]) (BoolAnd (Ann ()) [Space])
or_ :: Raw Expr -> Raw Expr -> Raw Expr
or_ a = BinOp (Ann ()) (a & trailingWhitespace .~ [Space]) (BoolOr (Ann ()) [Space])
instance InSyntax Expr (Raw Expr) where
in_ = mkBinOp $ In (Ann ())
instance e ~ Raw Expr => InSyntax InList [e] where
in_ = MkInList
notIn_ :: Raw Expr -> Raw Expr -> Raw Expr
notIn_ = mkBinOp $ NotIn (Ann ()) [Space]
infixl 1 `notIn_`
isNot_ :: Raw Expr -> Raw Expr -> Raw Expr
isNot_ = mkBinOp $ IsNot (Ann ()) [Space]
infixl 1 `isNot_`
not_ :: Raw Expr -> Raw Expr
not_ = Not (Ann ()) [Space]
(.==) :: Raw Expr -> Raw Expr -> Raw Expr
(.==) = mkBinOp $ Eq (Ann ())
infixl 1 .==
(.<) :: Raw Expr -> Raw Expr -> Raw Expr
(.<) = mkBinOp $ Lt (Ann ())
infixl 1 .<
(.<=) :: Raw Expr -> Raw Expr -> Raw Expr
(.<=) = mkBinOp $ LtEq (Ann ())
infixl 1 .<=
(.>) :: Raw Expr -> Raw Expr -> Raw Expr
(.>) = mkBinOp $ Gt (Ann ())
infixl 1 .>
(.>=) :: Raw Expr -> Raw Expr -> Raw Expr
(.>=) = mkBinOp $ GtEq (Ann ())
infixl 1 .>=
(.!=) :: Raw Expr -> Raw Expr -> Raw Expr
(.!=) = mkBinOp $ NotEq (Ann ())
infixl 1 .!=
(.|) :: Raw Expr -> Raw Expr -> Raw Expr
(.|) = mkBinOp $ BitOr (Ann ())
infixl 2 .|
(.^) :: Raw Expr -> Raw Expr -> Raw Expr
(.^) = mkBinOp $ BitXor (Ann ())
infixl 3 .^
(.&) :: Raw Expr -> Raw Expr -> Raw Expr
(.&) = mkBinOp $ BitAnd (Ann ())
infixl 4 .&
(.<<) :: Raw Expr -> Raw Expr -> Raw Expr
(.<<) = mkBinOp $ ShiftLeft (Ann ())
infixl 5 .<<
(.>>) :: Raw Expr -> Raw Expr -> Raw Expr
(.>>) = mkBinOp $ ShiftRight (Ann ())
infixl 5 .>>
(.+) :: Raw Expr -> Raw Expr -> Raw Expr
(.+) = (+)
infixl 6 .+
(.-) :: Raw Expr -> Raw Expr -> Raw Expr
(.-) = (-)
infixl 6 .-
(.*) :: Raw Expr -> Raw Expr -> Raw Expr
(.*) = (*)
infixl 7 .*
(.@) :: Raw Expr -> Raw Expr -> Raw Expr
(.@) = mkBinOp $ At (Ann ())
infixl 7 .@
(./) :: Raw Expr -> Raw Expr -> Raw Expr
(./) = mkBinOp $ Divide (Ann ())
infixl 7 ./
(.//) :: Raw Expr -> Raw Expr -> Raw Expr
(.//) = mkBinOp $ FloorDivide (Ann ())
infixl 7 .//
(.%) :: Raw Expr -> Raw Expr -> Raw Expr
(.%) = mkBinOp $ Percent (Ann ())
infixl 7 .%
(.**) :: Raw Expr -> Raw Expr -> Raw Expr
(.**) = mkBinOp $ Exp (Ann ())
infixr 8 .**
(/>) :: Raw Expr -> Raw Ident -> Raw Expr
(/>) a = Deref (Ann ()) a []
infixl 9 />
neg_ :: Raw Expr -> Raw Expr
neg_ = negate
pos_ :: Raw Expr -> Raw Expr
pos_ = UnOp (Ann ()) (Positive (Ann ()) [])
compl_ :: Raw Expr -> Raw Expr
compl_ = UnOp (Ann ()) (Complement (Ann ()) [])
linesToBlockIndented :: [Raw Line] -> Raw Block
linesToBlockIndented = over _Indents (indentIt $ replicate 4 Space) . linesToBlock
linesToBlock :: [Raw Line] -> Raw Block
linesToBlock = go
where
go [] = Block [] pass_ []
go [y] =
case unLine y of
Left l -> Block [l] pass_ []
Right st -> Block [] st []
go (y:ys) =
case unLine y of
Left l ->
case go ys of
Block a b c -> Block (l:a) b c
Right st -> Block [] st (unLine <$> ys)
instance BodySyntax While where
body = whileBody
body_ = mkBody_ whileIndents whileBody
instance ElseSyntax While where
getElse = mkGetElse _whileIndents _whileElse
setElse = mkSetElse _whileIndents whileElse
mkWhile :: Raw Expr -> [Raw Line] -> Raw While
mkWhile cond body =
MkWhile
{ _whileAnn = Ann ()
, _whileIndents = Indents [] (Ann ())
, _whileWhile = [Space]
, _whileCond = cond
, _whileBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
, _whileElse = Nothing
}
while_ :: Raw Expr -> [Raw Line] -> Raw While
while_ = mkWhile
mkIf :: Raw Expr -> [Raw Line] -> Raw If
mkIf cond body =
MkIf
{ _ifAnn = Ann ()
, _ifIndents = Indents [] (Ann ())
, _ifIf = [Space]
, _ifCond = cond
, _ifBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
, _ifElifs = []
, _ifElse = Nothing
}
instance BodySyntax Elif where
body = elifBody
body_ = mkBody_ elifIndents elifBody
instance BodySyntax Else where
body = elseBody
body_ = mkBody_ elseIndents elseBody
instance BodySyntax If where
body = ifBody
body_ = mkBody_ ifIndents ifBody
instance (l ~ Raw Line, s ~ Raw If) => IfSyntax ([l] -> s) where
if_ = mkIf
ifThen_ :: Raw Expr -> [Raw Line] -> Raw If
ifThen_ = mkIf
var_ :: String -> Raw Expr
var_ s = Ident (Ann ()) $ MkIdent (Ann ()) s []
none_ :: Raw Expr
none_ = None (Ann ()) []
int_ :: Integer -> Raw Expr
int_ = fromInteger
pass_ :: Raw Statement
pass_ =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement (Pass (Ann ()) []) [] Nothing Nothing (Just LF))
mkElif :: Raw Expr -> [Raw Line] -> Raw Elif
mkElif cond body =
MkElif
{ _elifIndents = Indents [] (Ann ())
, _elifElif = [Space]
, _elifCond = cond
, _elifBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
}
elif_ :: Raw Expr -> [Raw Line] -> Raw If -> Raw If
elif_ cond body code = code & ifElifs <>~ [mkElif cond body]
mkElse :: [Raw Line] -> Raw Else
mkElse body =
MkElse
{ _elseIndents = Indents [] (Ann ())
, _elseElse = []
, _elseBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
}
class ElseSyntax s where
getElse :: Raw s -> Maybe (Raw Else)
setElse :: [Whitespace] -> Maybe (Raw Else) -> Raw s -> Raw s
else_ :: ElseSyntax s => [Raw Line] -> Raw s -> Raw s
else_ body = setElse (replicate 4 Space) $ Just (mkElse body)
mkGetElse
:: (Raw s -> Indents ())
-> (Raw s -> Maybe (Raw Else))
-> Raw s
-> Maybe (Raw Else)
mkGetElse indentLevel elseField code =
fromMaybe
(error "malformed indentation in else block")
(traverseOf
(traverse._Indents)
(subtractStart (indentLevel code))
(elseField code))
mkSetElse
:: (Raw s -> Indents ())
-> Setter' (Raw s) (Maybe (Raw Else))
-> [Whitespace]
-> Maybe (Raw Else)
-> Raw s
-> Raw s
mkSetElse indentLevel elseField _ new code =
code &
elseField .~
fmap (elseIndents .~ indentLevel code)
(over
(traverse._Indents.indentsValue)
(indentLevel code ^. indentsValue <>)
new)
instance ElseSyntax For where
getElse = mkGetElse _forIndents _forElse
setElse = mkSetElse _forIndents forElse
instance ElseSyntax If where
getElse = mkGetElse _ifIndents _ifElse
setElse = mkSetElse _ifIndents ifElse
instance ElseSyntax TryExcept where
getElse = mkGetElse _teIndents _teElse
setElse = mkSetElse _teIndents teElse
break_ :: Raw Statement
break_ =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement (Break (Ann ()) []) [] Nothing Nothing (Just LF))
true_ :: Raw Expr
true_ = Bool (Ann ()) True []
false_ :: Raw Expr
false_ = Bool (Ann ()) False []
str_ :: String -> Raw Expr
str_ s =
String (Ann ()) . pure $
StringLiteral (Ann ()) Nothing ShortString DoubleQuote (Char_lit <$> s) []
str'_ :: String -> Raw Expr
str'_ s =
String (Ann ()) . pure $
StringLiteral (Ann ()) Nothing ShortString SingleQuote (Char_lit <$> s) []
longStr_ :: String -> Raw Expr
longStr_ s =
String (Ann ()) . pure $
StringLiteral (Ann ()) Nothing LongString DoubleQuote (Char_lit <$> s) []
longStr'_ :: String -> Raw Expr
longStr'_ s =
String (Ann ()) . pure $
StringLiteral (Ann ()) Nothing LongString SingleQuote (Char_lit <$> s) []
mkAugAssign :: AugAssignOp -> Raw Expr -> Raw Expr -> Raw Statement
mkAugAssign at a b =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement
(AugAssign
(Ann ())
(a & trailingWhitespace .~ [Space])
(MkAugAssign (Ann ()) at [Space]) b)
[]
Nothing
Nothing
(Just LF))
chainEq :: Raw Expr -> [Raw Expr] -> Raw Statement
chainEq t [] = expr_ t
chainEq t (a:as) =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement
(Assign (Ann ()) t $ (,) (MkEquals [Space]) <$> (a :| as))
[]
Nothing
Nothing
(Just LF))
(.=) :: Raw Expr -> Raw Expr -> Raw Statement
(.=) a b =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement
(Assign (Ann ()) (a & trailingWhitespace .~ [Space]) $ pure (MkEquals [Space], b))
[]
Nothing
Nothing
(Just LF))
infix 0 .=
(.+=) :: Raw Expr -> Raw Expr -> Raw Statement
(.+=) = mkAugAssign PlusEq
infix 0 .+=
(.-=) :: Raw Expr -> Raw Expr -> Raw Statement
(.-=) = mkAugAssign MinusEq
infix 0 .-=
(.*=) :: Raw Expr -> Raw Expr -> Raw Statement
(.*=) = mkAugAssign StarEq
infix 0 .*=
(.@=) :: Raw Expr -> Raw Expr -> Raw Statement
(.@=) = mkAugAssign AtEq
infix 0 .@=
(./=) :: Raw Expr -> Raw Expr -> Raw Statement
(./=) = mkAugAssign SlashEq
infix 0 ./=
(.%=) :: Raw Expr -> Raw Expr -> Raw Statement
(.%=) = mkAugAssign PercentEq
infix 0 .%=
(.&=) :: Raw Expr -> Raw Expr -> Raw Statement
(.&=) = mkAugAssign AmpersandEq
infix 0 .&=
(.|=) :: Raw Expr -> Raw Expr -> Raw Statement
(.|=) = mkAugAssign PipeEq
infix 0 .|=
(.^=) :: Raw Expr -> Raw Expr -> Raw Statement
(.^=) = mkAugAssign CaretEq
infix 0 .^=
(.<<=) :: Raw Expr -> Raw Expr -> Raw Statement
(.<<=) = mkAugAssign ShiftLeftEq
infix 0 .<<=
(.>>=) :: Raw Expr -> Raw Expr -> Raw Statement
(.>>=) = mkAugAssign ShiftRightEq
infix 0 .>>=
(.**=) :: Raw Expr -> Raw Expr -> Raw Statement
(.**=) = mkAugAssign DoubleStarEq
infix 0 .**=
(.//=) :: Raw Expr -> Raw Expr -> Raw Statement
(.//=) = mkAugAssign DoubleSlashEq
infix 0 .//=
mkFor :: Raw Expr -> [Raw Expr] -> [Raw Line] -> Raw For
mkFor binder collection body =
MkFor
{ _forAnn = Ann ()
, _forIndents = Indents [] (Ann ())
, _forAsync = Nothing
, _forFor = [Space]
, _forBinder = binder & trailingWhitespace .~ [Space]
, _forIn = [Space]
, _forCollection =
fromMaybe
(CommaSepOne1' (Unit (Ann ()) [] []) Nothing)
(listToCommaSep1' collection)
, _forBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
, _forElse = Nothing
}
instance (l ~ [Raw Line], s ~ Raw For) => ForSyntax (l -> s) InList where
for_ (MkInList a b) = mkFor a b
forSt_ :: Raw Expr -> [Raw Expr] -> [Raw Line] -> Raw For
forSt_ = mkFor
instance BodySyntax For where
body = forBody
body_ = mkBody_ forIndents forBody
instance AsLine For where
line_ = line_ @Statement . (_For #)
class AsyncSyntax s where
async_ :: Raw s -> Raw s
instance AsyncSyntax Fundef where
async_ = fdAsync ?~ pure Space
instance AsyncSyntax For where
async_ = forAsync ?~ pure Space
mkFinally :: [Raw Line] -> Raw Finally
mkFinally body =
MkFinally
{ _finallyIndents = Indents [] (Ann ())
, _finallyFinally = []
, _finallyBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
}
mkExcept :: [Raw Line] -> Raw Except
mkExcept body =
MkExcept
{ _exceptIndents = Indents [] (Ann ())
, _exceptExcept = []
, _exceptExceptAs = Nothing
, _exceptBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
}
mkTryExcept :: [Raw Line] -> Raw Except -> Raw TryExcept
mkTryExcept body except =
MkTryExcept
{ _teAnn = Ann ()
, _teIndents = Indents [] (Ann ())
, _teTry = [Space]
, _teBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
, _teExcepts = pure except
, _teElse = Nothing
, _teFinally = Nothing
}
mkTryFinally :: [Raw Line] -> [Raw Line] -> Raw TryFinally
mkTryFinally body fBody =
MkTryFinally
{ _tfAnn = Ann ()
, _tfIndents = Indents [] (Ann ())
, _tfTry = [Space]
, _tfBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
, _tfFinally = mkFinally fBody
}
class FinallySyntax s t | s -> t where
finally_ :: [Raw Line] -> s -> Raw t
instance FinallySyntax (Raw TryExcept) TryExcept where
finally_ body = teFinally ?~ mkFinally body
instance FinallySyntax (Raw TryFinally) TryFinally where
finally_ body = tfFinally .~ mkFinally body
instance (a ~ [Raw Line], b ~ Raw TryFinally) => FinallySyntax (a -> b) TryFinally where
finally_ body f = f body
instance BodySyntax TryExcept where
body = teBody
body_ = mkBody_ teIndents teBody
tryE_ :: [Raw Line] -> Raw Except -> Raw TryExcept
tryE_ = mkTryExcept
instance BodySyntax TryFinally where
body = tfBody
body_ = mkBody_ tfIndents tfBody
tryF_ :: [Raw Line] -> [Raw Line] -> Raw TryFinally
tryF_ = mkTryFinally
class AsExceptAs s where
toExceptAs :: Raw s -> Raw ExceptAs
instance AsExceptAs ExceptAs where
toExceptAs = id
instance AsExceptAs Expr where
toExceptAs e = ExceptAs (Ann ()) e Nothing
class ExceptSyntax s where
except_ :: [Raw Line] -> s -> Raw TryExcept
exceptAs_ :: AsExceptAs e => Raw e -> [Raw Line] -> s -> Raw TryExcept
instance (e ~ Raw Except, s ~ Raw TryExcept) => ExceptSyntax (e -> s) where
except_ body f = f $ mkExcept body
exceptAs_ ea body f = f $ mkExcept body & exceptExceptAs ?~ toExceptAs ea
instance ExceptSyntax (Raw TryExcept) where
except_ body = teExcepts %~ (<> pure (mkExcept body))
exceptAs_ ea body =
teExcepts %~ (<> pure (mkExcept body & exceptExceptAs ?~ toExceptAs ea))
instance ExceptSyntax (Raw TryFinally) where
except_ body MkTryFinally{..} =
MkTryExcept
{ _teAnn = _tfAnn
, _teIndents = _tfIndents
, _teTry = _tfTry
, _teBody = _tfBody
, _teExcepts = pure $ mkExcept body
, _teElse = Nothing
, _teFinally = Just _tfFinally
}
exceptAs_ ea body MkTryFinally{..} =
MkTryExcept
{ _teAnn = _tfAnn
, _teIndents = _tfIndents
, _teTry = _tfTry
, _teBody = _tfBody
, _teExcepts = pure $ mkExcept body & exceptExceptAs ?~ toExceptAs ea
, _teElse = Nothing
, _teFinally = Just _tfFinally
}
instance AsLine TryExcept where
line_ = line_ @Statement . (_TryExcept #)
instance AsLine TryFinally where
line_ = line_ @Statement . (_TryFinally #)
class As s t u | s t -> u, u -> s t where
as_ :: Raw s -> Raw t -> Raw u
instance As Expr Ident ExceptAs where
as_ e name = ExceptAs (Ann ()) e $ Just ([Space], name)
class_ :: Raw Ident -> [Raw Arg] -> [Raw Line] -> Raw ClassDef
class_ name args body =
(mkClassDef name body) {
_cdArguments =
case args of
[] -> Nothing
a:as -> Just ([], Just $ (a, zip (repeat (MkComma [Space])) as, Nothing) ^. _CommaSep1', [])
}
mkClassDef :: Raw Ident -> [Raw Line] -> Raw ClassDef
mkClassDef name body =
MkClassDef
{ _cdAnn = Ann ()
, _cdDecorators = []
, _cdIndents = Indents [] (Ann ())
, _cdClass = Space :| []
, _cdName = name
, _cdArguments = Nothing
, _cdBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
}
instance BodySyntax ClassDef where
body = cdBody
body_ = mkBody_ cdIndents cdBody
instance DecoratorsSyntax ClassDef where
decorators = cdDecorators
setDecorators new code =
code
{ _cdDecorators = exprsToDecorators (_cdIndents code) new
}
getDecorators code = code ^.. cdDecorators.folded._Exprs
instance ArgumentsSyntax ClassDef where
setArguments args code =
code
{ _cdArguments =
case args of
[] -> Nothing
a:as -> Just ([], Just $ (a, zip (repeat (MkComma [Space])) as, Nothing) ^. _CommaSep1', [])
}
getArguments code = _cdArguments code ^.. folded._2.folded.folded
mkWith :: NonEmpty (Raw WithItem) -> [Raw Line] -> Raw With
mkWith items body =
MkWith
{ _withAnn = Ann ()
, _withIndents = Indents [] (Ann ())
, _withAsync = Nothing
, _withWith = [Space]
, _withItems = listToCommaSep1 items
, _withBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
}
with_ :: AsWithItem e => NonEmpty (Raw e) -> [Raw Line] -> Raw With
with_ items = mkWith (toWithItem <$> items)
withItem_ :: Raw Expr -> Maybe (Raw Expr) -> Raw WithItem
withItem_ a b = WithItem (Ann ()) a ((,) [Space] <$> b)
instance As Expr Expr WithItem where
as_ a b = WithItem (Ann ()) a $ Just ([Space], b)
class AsWithItem s where
toWithItem :: Raw s -> Raw WithItem
instance AsWithItem Expr where
toWithItem e = WithItem (Ann ()) e Nothing
instance AsWithItem WithItem where
toWithItem = id
instance BodySyntax With where
body = withBody
body_ = mkBody_ withIndents withBody
instance AsyncSyntax With where
async_ = withAsync ?~ pure Space
ellipsis_ :: Raw Expr
ellipsis_ = Ellipsis (Ann ()) []
class AsTupleItem e where
ti_ :: Raw e -> Raw TupleItem
instance StarSyntax Expr TupleItem where
s_ = TupleUnpack (Ann ()) [] []
instance AsTupleItem Expr where
ti_ = TupleItem (Ann ())
instance AsTupleItem TupleItem where
ti_ = id
tuple_ :: [Raw TupleItem] -> Raw Expr
tuple_ [] = Unit (Ann ()) [] []
tuple_ (a:as) =
case as of
[] -> Tuple (Ann ()) (ti_ a) (MkComma []) Nothing
b:bs ->
Tuple (Ann ()) a (MkComma [Space]) . Just $
(b, zip (repeat (MkComma [Space])) bs, Nothing) ^. _CommaSep1'
await_ :: Raw Expr -> Raw Expr
await_ = Await (Ann ()) [Space]
ifThenElse_ :: Raw Expr -> Raw Expr -> Raw Expr -> Raw Expr
ifThenElse_ a b = Ternary (Ann ()) a [Space] b [Space]
lambda_ :: [Raw Param] -> Raw Expr -> Raw Expr
lambda_ params =
Lambda (Ann ())
(if null params then [] else [Space])
(listToCommaSep params)
(MkColon [Space])
yield_ :: [Raw Expr] -> Raw Expr
yield_ as = Yield (Ann ()) (foldr (\_ _ -> [Space]) [] as) (listToCommaSep as)
yieldFrom_ :: Raw Expr -> Raw Expr
yieldFrom_ = YieldFrom (Ann ()) [Space] [Space]
fullSlice_ :: Raw Expr
fullSlice_ = slice_ Nothing Nothing Nothing
sliceS_ :: Raw Expr -> Raw Expr
sliceS_ x = slice_ Nothing Nothing (Just x)
sliceF_ :: Raw Expr -> Raw Expr
sliceF_ x = slice_ (Just x) Nothing Nothing
sliceFS_ :: Raw Expr -> Raw Expr -> Raw Expr
sliceFS_ x y = slice_ (Just x) Nothing (Just y)
sliceT_ :: Raw Expr -> Raw Expr
sliceT_ x = slice_ Nothing (Just x) Nothing
sliceTS_ :: Raw Expr -> Raw Expr -> Raw Expr
sliceTS_ x y = slice_ Nothing (Just x) (Just y)
sliceFT_ :: Raw Expr -> Raw Expr -> Raw Expr
sliceFT_ x y = slice_ (Just x) (Just y) Nothing
sliceFTS_ :: Raw Expr -> Raw Expr -> Raw Expr -> Raw Expr
sliceFTS_ x y z = slice_ (Just x) (Just y) (Just z)
slice_ :: Maybe (Raw Expr) -> Maybe (Raw Expr) -> Maybe (Raw Expr) -> Raw Expr
slice_ a b c =
call_ (var_ "slice")
[ p_ $ fromMaybe none_ a
, p_ $ fromMaybe none_ b
, p_ $ fromMaybe none_ c
]
subs_ :: Raw Expr -> Raw Expr -> Raw Expr
subs_ a e =
Subscript (Ann ()) a
[]
(exprToSubscript e ^. _CommaSep1')
[]
where
exprToSubscript
:: Raw Expr
-> (Raw Subscript, [(Comma, Raw Subscript)], Maybe Comma)
exprToSubscript e =
let
notSlice :: (Raw Subscript, [(Comma, Raw Subscript)], Maybe Comma)
notSlice =
case e ^? _Tuple of
Nothing -> (SubscriptExpr e, [], Nothing)
Just tup ->
let
h = tup ^. tupleHead
comma = tup ^. tupleComma
t = tup ^? tupleTail._Just.from _CommaSep1'
res =
case t of
Just (a, bs, c) ->
(,,) <$>
fromTupleItem h <*>
traverseOf (traverse._2) fromTupleItem ((comma, a) : bs) <*>
pure c
Nothing -> (\a -> (a, [], Just comma)) <$> fromTupleItem h
in
fromMaybe (SubscriptExpr e, [], Nothing) res
in
maybe notSlice (\a -> (a, [], Nothing)) $ mkSlice e
where
mkSlice
:: Raw Expr
-> Maybe (Raw Subscript)
mkSlice e = do
c <- e ^? _Call
case c ^? callFunction._Ident.identValue of
Just "slice" ->
pure $ case c ^.. callArguments.folded.folded of
[PositionalArg _ x] ->
SubscriptSlice Nothing (MkColon []) (Just x) Nothing
[PositionalArg _ x, PositionalArg _ y] ->
SubscriptSlice
(noneToMaybe x)
(MkColon [])
(noneToMaybe y)
Nothing
[PositionalArg _ x, PositionalArg _ y, PositionalArg _ z] ->
SubscriptSlice
(noneToMaybe x)
(MkColon [])
(noneToMaybe y)
((,) (MkColon []) . Just <$> noneToMaybe z)
_ -> SubscriptExpr e
_ -> Nothing
noneToMaybe x = fromMaybe (Just x) $ Nothing <$ (x ^? _None)
fromTupleItem
:: Raw TupleItem
-> Maybe (Raw Subscript)
fromTupleItem (TupleItem _ a) = mkSlice a <|> pure (SubscriptExpr a)
fromTupleItem _ = Nothing