hpython-0.2: src/Language/Python/DSL.hs
{-|
Module : Language.Python.DSL
Copyright : (C) CSIRO 2017-2019
License : BSD3
Maintainer : Isaac Elliott <isaace71295@gmail.com>
Stability : experimental
Portability : non-portable
Passing @[]@ to a function which expects a @['Raw' 'Line']@ is the same as
passing @['line_' 'pass_']@
-}
{-# 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
-- * Modules
, module_
-- * Lines of code
, blank_
, AsLine(..)
, Line(..)
-- * Identifiers
, id_
, Ident(..)
-- ** Lenses
, identAnn
, identValue
, identWhitespace
-- * Starred values
, StarSyntax(..)
, star_
-- * Double-starred values
, DoubleStarSyntax(..)
-- * @as@ syntax
, As(..)
-- * @if@ syntax
, IfSyntax(..)
-- * @for@ syntax
, ForSyntax(..)
-- * @in@ syntax
, InSyntax(..), In(..), InList(..)
-- * @:@ syntax
, ColonSyntax(..)
-- * Comprehensions
, comp_
, Guard(..)
-- * Parameters and arguments
-- ** Parameters
, Param(..)
, ParametersSyntax(..)
-- ** Arguments
, Arg(..)
, ArgumentsSyntax(..)
-- ** Positional
, PositionalSyntax(..)
, PositionalParam(..)
, _PositionalParam
-- *** Lenses
, ppAnn
, ppName
, ppType
-- ** Keyword
, KeywordSyntax(..)
, KeywordParam(..)
, _KeywordParam
-- *** Lenses
, kpAnn
, kpName
, kpType
, kpEquals
, kpExpr
-- * Decorators
, decorated_
, DecoratorsSyntax(..)
-- * Statements
-- ** @async@
, AsyncSyntax(..)
-- ** Block bodies
, BodySyntax(..)
-- ** Function definitions
, def_
, Fundef(..)
, mkFundef
-- *** Lenses
, fdAnn
, fdDecorators
, fdIndents
, fdAsync
, fdDefSpaces
, fdName
, fdLeftParenSpaces
, fdParameters
, fdRightParenSpaces
, fdReturnType
, fdBody
-- ** Class definitions
, class_
, ClassDef(..)
, mkClassDef
-- *** Lenses
, cdAnn
, cdDecorators
, cdIndents
, cdClass
, cdName
, cdArguments
, cdBody
-- ** Assignment
, chainEq
, (.=)
, (.+=)
, (.-=)
, (.*=)
, (.@=)
, (./=)
, (.%=)
, (.&=)
, (.|=)
, (.^=)
, (.<<=)
, (.>>=)
, (.**=)
, (.//=)
-- ** Exceptions
, tryE_
, tryF_
, ExceptSyntax(..)
, FinallySyntax(..)
, TryExcept(..)
, mkTryExcept
, TryFinally(..)
, mkTryFinally
, ExceptAs(..)
, AsExceptAs(..)
, Except(..)
, mkExcept
, Finally(..)
, mkFinally
-- *** Lenses
, teAnn
, teIndents
, teTry
, teBody
, teExcepts
, teElse
, teFinally
, exceptIndents
, exceptExcept
, exceptExceptAs
, exceptBody
, finallyIndents
, finallyFinally
, finallyBody
-- ** With statements
, with_
, withItem_
, With(..)
, mkWith
, AsWithItem(..)
, WithItem(..)
-- *** Lenses
, withAnn
, withIndents
, withAsync
, withWith
, withItems
, withBody
-- ** Flow control
-- *** 'Else' clauses
-- | 'If', 'While', 'For', and 'TryExcept' statements can have an 'Else'
-- component.
--
-- 'else_' is considered to be a modifier on these structures.
--
-- \-\-\-
--
-- 'If' ... 'Else':
--
-- >>> if_ false_ [line_ pass_] & else_ [line_ pass_]
-- if False:
-- pass
-- else:
-- pass
--
-- \-\-\-
--
-- 'While' ... 'Else':
--
-- >>> while_ false_ [line_ pass_] & else_ [line_ pass_]
-- while False:
-- pass
-- else:
-- pass
--
-- \-\-\-
--
-- 'For' ... 'Else':
--
-- >>> for_ (var_ "a" `in_` [var_ b]) [line_ pass_] & else_ [line_ pass_]
-- for a in b:
-- pass
-- else:
-- pass
--
-- \-\-\-
--
-- 'TryExcept' ... 'Else':
--
-- >>> tryE_ [line_ pass_] & except_ [line_ pass_] & else_ [line_ pass_]
-- try:
-- pass
-- except:
-- pass
-- else:
-- pass
, else_
, ElseSyntax(..)
-- *** Break
, break_
-- *** For loops
-- | 'For' loops are built using 'for_' syntax:
--
-- >>> for_ (var_ "a" `in_` [1, 2, 3]) [line_ (call_ "print" [var_ "a"])]
-- for a in 1, 2, 3:
-- print(a)
--
-- See also: 'ForSyntax'
, forSt_
, For(..)
, _For
, mkFor
-- *** If statements
, ifThen_
, elif_
, If(..)
, mkIf
, Elif(..)
, mkElif
, Else(..)
, mkElse
-- **** Lenses
, ifAnn
, ifIndents
, ifIf
, ifCond
, ifBody
, ifElifs
, ifElse
, elifIndents
, elifElif
, elifCond
, elifBody
, elseIndents
, elseElse
, elseBody
-- *** Pass
, pass_
-- *** Return
, return_
-- *** While loops
, while_
, While(..)
, mkWhile
-- **** Lenses
, whileAnn
, whileIndents
, whileWhile
, whileCond
, whileBody
-- * Expressions
, expr_
, var_
-- ** @await@
, await_
-- ** @... if ... else ...@
, ifThenElse_
-- ** Generators
, gen_
-- ** @yield@
, yield_
-- ** @yield from ...@
, yieldFrom_
-- ** Tuples
, tuple_
, Tuple(..)
, AsTupleItem(..)
, TupleItem()
-- ** Function calls
, call_
, Call(..)
, mkCall
-- *** Lenses
, callAnn
, callFunction
, callLeftParen
, callArguments
, callRightParen
-- ** Literals
-- *** @None@
, none_
, None(..)
, _None
-- **** Lenses
, noneAnn
, noneWhitespace
-- *** Strings
, str_
, str'_
, longStr_
, longStr'_
-- *** Integers
, int_
-- *** Booleans
, true_
, false_
-- *** Ellipses
, ellipsis_
-- ** Lists
, AsList(..)
, AsListItem(..)
, ListItem()
-- ** Dictionaries
, AsDict(..)
, DictItem()
-- ** Sets
, AsSet(..)
, AsSetItem(..)
, SetItem()
-- ** Lambdas
, lambda_
-- ** Subscripting
, subs_
-- *** Slicing
, sliceF_
, sliceFS_
, sliceT_
, sliceTS_
, sliceFT_
, sliceFTS_
, sliceS_
, fullSlice_
, slice_
-- ** Dereferencing
, (/>)
-- ** Unary operators
, not_
, neg_
, pos_
, compl_
-- ** Binary operators
-- | Comparison, bitwise, and arithmetic operators have precedences that are
-- consistent with their Python counterparts. This meansPython expressions can
-- be translated to kellSyntax with minimal parentheses.
--
-- Note: this doesn't apply to unary operators (because kellSyntax doesn't have
-- unary operators), or the boolean operations 'and_' and 'or_' (because we ran
-- out of precedence levels)
-- *** Boolean operations
, or_
, and_
-- *** Comparison operations
, is_
, isNot_
, notIn_
, (.==)
, (.>)
, (.>=)
, (.<)
, (.<=)
, (.!=)
-- *** Bitwise operations
, (.|)
, (.^)
, (.&)
, (.<<)
, (.>>)
-- *** Arithmetic operations
, (.-)
, (.+)
, (.*)
, (.@)
, (./)
, (.//)
, (.%)
, (.**)
-- * Miscellaneous
, 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
-- | 'Ident' has an 'Data.String.IsString' instance, but when a type class dispatches on
-- an 'Ident' we will run into ambiguity if we try to use @OverloadedStrings@. In these
-- cases we can use 'id_' to provide the extra type information
id_ :: String -> Raw Ident
id_ = fromString
-- | Create a 'Module'
--
-- >>> module_
-- >>> [ line_ $ def_ "a" [] [line_ pass_]
-- >>> , blank_
-- >>> , line_ $ def_ "b" [] [line_ pass_]
-- >>> ]
-- def a():
-- pass
-- <BLANKLINE>
-- def b():
-- pass
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
-- | One or more lines of Python code
newtype Line v a
= Line
{ unLine :: Either (Blank a, Newline) (Statement v a)
} deriving (Eq, Show)
makeWrapped ''Line
-- | Create a blank 'Line'
blank_ :: Raw Line
blank_ = Line $ Left (Blank (Ann ()) [] Nothing, LF)
-- | Convert some data to a 'Line'
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
-- | A faux-Lens that targets lines in the body of some statement-piece, but
-- does so \'around\' indentation.
--
-- >>> def_ "a" [] [ line_ pass_, line_ pass_ ]
-- def a ():
-- pass
-- pass
--
-- >>> def_ "a" [] [ line_ pass_, line_ pass_ ] ^. body_
-- pass
-- pass
--
-- >>> def_ "a" [] [ line_ pass_, line_ pass_ ] & body_ .~ [ line_ $ var_ "b" += 1 ]
-- def a():
-- b += 1
--
-- >>> def_ "a" [] [ line_ pass_, line_ pass_ ] & body_ <>~ [ line_ $ var_ "b" += 1 ]
-- def a():
-- pass
-- pass
-- b += 1
--
-- >>> def_ "a" [] [ line_ pass_, line_ pass_ ] & body_ .~ []
-- def a():
-- pass
--
-- \-\-\-
--
-- It's a fake 'Lens' because it violates some of the laws. The most obvious violation is
-- that setting the 'body_' to the empty list actually sets it to a singleton list containing
-- 'pass_'. (This is because blocks must contain one or more statements)
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 .:
-- | Constructing dictionary items
--
-- @('.:') :: 'Raw' 'Expr' -> 'Raw' 'Expr' -> 'Raw' 'DictItem'@
instance ColonSyntax Expr DictItem where
(.:) a = DictItem (Ann ()) a (MkColon [Space])
-- | Function parameter type annotations
--
-- @('.:') :: 'Raw' 'Param' -> 'Raw' 'Expr' -> 'Raw' 'Param'@
--
-- 'star_' can be annotated using '.:', but it will have no effect on the output program,
-- as unnamed starred parameters cannot have type annotations.
--
-- See 'def_'
instance ColonSyntax Param Param where
(.:) p t = p & paramType_ ?~ (MkColon [Space], t)
-- | Positional parameters/arguments
--
-- @
-- p_ :: 'Raw' 'Expr' -> 'Raw' 'Arg'
-- @
--
-- @
-- p_ :: 'Raw' 'Ident' -> 'Raw' 'Param'
-- @
class PositionalSyntax p v | p -> v, v -> p where
p_ :: Raw v -> Raw p
-- | See 'def_'
instance StarSyntax Ident Param where
s_ i = StarParam (Ann ()) [] i Nothing
-- | See 'def_'
instance DoubleStarSyntax Ident Param where
ss_ i = DoubleStarParam (Ann ()) [] i Nothing
class StarSyntax s t | t -> s where
s_ :: Raw s -> Raw t
-- | See 'call_'
instance StarSyntax Expr Arg where
s_ = StarArg (Ann ()) []
-- | See 'call_'
instance DoubleStarSyntax Expr Arg where
ss_ = DoubleStarArg (Ann ()) []
-- | Keyword parameters/arguments
--
-- @
-- p_ :: 'Raw' 'Expr' -> 'Raw' 'Expr' -> 'Raw' 'Arg'
-- @
--
-- @
-- p_ :: 'Raw' 'Ident' -> 'Raw' 'Expr' -> 'Raw' 'Param'
-- @
class KeywordSyntax p where
k_ :: Raw Ident -> Raw Expr -> Raw p
-- | Unnamed starred parameter
--
-- >>> def_ "a" [ p_ "b", star_ ] [ line_ pass_ ]
-- def a(b, *):
-- pass
star_ :: Raw Param
star_ = UnnamedStarParam (Ann ()) []
class DoubleStarSyntax s t | t -> s where
ss_ :: Raw s -> Raw t
-- | See 'dict_'
instance DoubleStarSyntax Expr DictItem where
ss_ = DictUnpack (Ann ()) []
-- | See 'def_'
instance PositionalSyntax Param Ident where
p_ i = PositionalParam (Ann ()) i Nothing
-- | See 'def_'
instance KeywordSyntax Param where
k_ a = KeywordParam (Ann ()) a Nothing []
-- | See 'call_'
instance PositionalSyntax Arg Expr where; p_ = PositionalArg (Ann ())
-- | See 'call_'
instance KeywordSyntax Arg where; k_ a = KeywordArg (Ann ()) a []
class ParametersSyntax s where
-- | A faux-Lens that allows targeting 'Param's in-between existing formatting,
-- and adding appropriate formatting when extra parameters are introduced.
--
-- >>> showStatement myStatement
-- "def a(b , c ):\n pass"
--
-- >>> showStatement (myStatement & _Fundef.parameters_ .~ [p_ "d", p_ "e"]
-- "def a(d , e ):\n pass"
--
-- >>> showStatement (myStatement & _Fundef.parameters_ .~ [p_ "d", p_ "e", p_ "f"]
-- "def a(d , e , f):\n pass"
--
-- \-\-\-
--
-- It's not a 'Lens' because repeated 'set's can drop trailing commas, violating
-- the 'Lens' laws. For example:
--
-- >>> someFunction
-- def a(b, c,):
-- pass
--
-- >>> set parameters_ [var_ "d", var_ "e"] someFunction
-- def a(d, e,):
-- pass
--
-- >>> set parameters_ [] someFunction
-- def a():
-- pass
--
-- >>> set parameters_ [var_ "d", var_ "e"] (set parameters_ [] someFunction)
-- def a(d, e):
-- pass
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
-- | The default indent amount is the indentation level of the first statement
-- in a block. If the first statement has no indentation, it defaults to 4
-- spaces.
defaultIndent =
fromMaybe
(Indents [replicate 4 Space ^. from indentWhitespaces] (Ann ()))
(e ^? gIndents)
-- | The number of indentation chunks that precede the lines we're focusing on.
--
-- It's one more than @defaultIndent@.
--
-- For example, if we're looking at this code, which is inside some larger
-- context:
--
-- @
-- def a():
-- pass
-- @
--
-- @defaultIndent@ refers to this part:
--
-- @
-- def a():
-- ^^^^
-- @
--
-- It's a single chunk. The code body has 2 (= one + 1) chunks:
--
-- @
-- def a():
-- pass
-- ^^^^
-- @
--
-- and
--
-- @
-- def a():
-- pass
-- ^^
-- @
--
-- So we will need to drop/take two chunks from the beginning of each line in
-- the body.
numChunks = lengthOf (indentsValue.folded) defaultIndent + 1
-- | The lines of the block
blLines = e ^.. gBody._Blocks.to blockToLines.folded
-- | The lines of the block, with leading indentation chopped off appropriately
--
-- For example:
--
-- @
-- def a():
-- pass
-- pass
-- @
--
-- the unprocessed lines are:
--
-- @
-- pass
-- pass
-- @
--
-- so the processed lines should be:
--
-- @
-- pass
-- pass
-- @
blLines' =
f $
over
(mapped._Wrapped._Right._Indents.indentsValue)
(drop numChunks)
blLines
-- | @defaultNewIndent@ is the amount of indentation that 'new' lines should get.
-- 'New' lines are only introduced when we set the @[Raw Line]@ to a list longer
-- than its original value.
--
-- @allIndents@ is a list of indentation corresponding to the indents of the old
-- @[Raw Line]@
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@ zips the old indentation with the new lines, but if the new
-- list of lines is longer than the old one then the extra lines at the end
-- are indented by @defaultNewIndent@
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
-- | Create a minimal valid function definition
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_ "f" [p_ "x"] [line_ $ return_ "x"]
-- def f(x):
-- return x
--
-- >>> def_ "f" [p_ "x", k_ "y" 2] [line_ $ return_ "x"]
-- def f(x, y=2):
-- return x
--
-- >>> def_ "f" [p_ "x", k_ "y" 2, s_ "z"] [line_ $ return_ "x"]
-- def f(x, y=2, *z):
-- return x
--
-- >>> def_ "f" [p_ "x", k_ "y" 2, s_ "z", ss_ "w"] [line_ $ return_ "x"]
-- def f(x, y=2, *z, **w)
-- return x
--
-- >>> def_ "f" [p_ "x" .: "String"] [line_ $ return_ "x"]
-- def f(x: String):
-- return x
def_ :: Raw Ident -> [Raw Param] -> [Raw Line] -> Raw Fundef
def_ name params body = (mkFundef name body) { _fdParameters = listToCommaSep params }
-- | Create a minimal valid 'Call'
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_ "f" [p_ $ var_ "x"]
-- f(x)
--
-- >>> call_ "f" [p_ $ var_ "x", k_ "y" 2]
-- f(x, y=2)
--
-- >>> call_ "f" [p_ $ var_ "x", k_ "y" 2, s_ "z"]
-- f(x, y=2, *z)
--
-- >>> call_ "f" [p_ $ var_ "x", k_ "y" 2, s_ "z", ss_ "w"]
-- f(x, y=2, *z, **w)
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_ (var_ "a")
-- return a
return_ :: Raw Expr -> Raw Statement
return_ e =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement (Return (Ann ()) [Space] $ Just e) [] Nothing Nothing (Just LF))
-- | Turns an 'Expr' into a 'Statement'
--
-- >>> expr_ (int_ 3)
-- 3
expr_ :: Raw Expr -> Raw Statement
expr_ e =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement (Expr (Ann ()) e) [] Nothing Nothing (Just LF))
-- |
-- >>> list_ [li_ $ var_ "a"]
-- [a]
--
-- >>> list_ [s_ $ var_ "a"]
-- [*a]
--
-- >>> list_ [li_ $ var_ "a", s_ $ var_ "b"]
-- [a, *b]
--
-- >>> list_ $ comp_ (var_ "a") (for_ $ var_ "a" `in_` list_ [li_ $ int_ 1, li_ $ int_ 2, li_ $ int_ 3]) [if_ $ var_ "a" .== 2]
-- [a for a in [1, 2, 3] if a == 2]
class AsList s where
list_ :: s -> Raw Expr
class AsListItem s where
-- | Create a 'ListItem'
li_ :: Raw s -> Raw ListItem
instance AsListItem ListItem where
li_ = id
instance AsListItem Expr where
li_ = ListItem (Ann ())
-- | See 'list_'
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
-- |
-- @'for_' :: 'Raw' 'In' -> 'Raw' 'CompFor'@
--
-- >>> comp_ (var_ "a") (for_ $ var_ "a" `in_` var_ "b") []
-- a for a in b
instance ForSyntax (Raw CompFor) In where
for_ (MkIn a b) = CompFor (Ann ()) [Space] a [Space] b
-- |
-- @'for_' :: 'Raw' 'In' -> 'Raw' 'Guard'@
--
-- >>> comp_ (var_ "a") (for_ $ var_ "a" `in_` var_ "b") [for_ $ var_ "c" `in_` var_ "d"]
-- a for a in b for c in d
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
-- |
-- @'if_' :: 'Raw' 'Expr' -> 'Raw' 'Guard'@
--
-- >>> comp_ (var_ "a") (for_ $ var_ "a" `in_` var_ "b") [if_ $ var_ "c" .== var_ "d"]
-- a for a in b if c == d
instance IfSyntax (Raw Guard) where
if_ = MkGuard . Right . CompIf (Ann ()) [Space]
-- |
-- >>> set_ []
-- set()
--
-- >>> set_ [si_ $ var_ "a"]
-- {a}
--
-- >>> set_ [s_ $ var_ "a"]
-- {*a}
--
-- >>> set_ [si_ $ var_ "a", s_ $ var_ "b"]
-- {a, *b}
--
-- >>> set_ $ comp_ (var_ "a") (for_ $ var_ "a" `in_` set_ [si_ $ int_ 1, si_ $ int_ 2, si_ $ int_ 3]) [if_ $ var_ "a" .== 2]
-- {a for a in [1, 2, 3] if a == 2}
class AsSet s where
set_ :: s -> Raw Expr
class AsSetItem s where
-- | Create a 'SetItem'
si_ :: Raw s -> Raw SetItem
instance AsSetItem SetItem where
si_ = id
instance AsSetItem Expr where
si_ = SetItem (Ann ())
-- | See 'set_'
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_ $ comp_ (var_ "a") (for_ $ var_ "a" `in_` list_ [li_ $ int_ 1, li_ $ int_ 2, li_ $ int_ 3]) [if_ $ var_ "a" .== 2]
-- (a for a in [1, 2, 3] if a == 2)
gen_ :: Raw (Comprehension Expr) -> Raw Expr
gen_ = Generator (Ann ())
-- |
-- >>> dict_ [var_ "a" .: 1]
-- {a: 1}
--
-- >>> dict_ [ss_ $ var_ "a"]
-- {**a}
--
-- >>> dict_ [var_ "a" .: 1, ss_ $ var_ "b"]
-- {a: 1, **b}
--
-- >>> dict_ $ comp_ (var_ "a" .: 1) (for_ $ var_ "a" `in_` list_ [li_ $ int_ 1, li_ $ int_ 2, li_ $ int_ 3]) [if_ $ var_ "a" .== 2]
-- {a: 1 for a in [1, 2, 3] if a == 2}
class AsDict s where
dict_ :: s -> Raw Expr
-- |
-- @'dict_' :: ['Raw' 'DictItem'] -> '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')
[]
-- |
-- @'dict_' :: 'Raw' ('Comprehension' 'DictItem') -> 'Raw' 'Expr'@
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])
-- | @a is b@
is_ :: Raw Expr -> Raw Expr -> Raw Expr
is_ = mkBinOp $ Is (Ann ())
infixl 1 `is_`
-- |
-- >>> var_ "a" `in_` var_ "b"
-- a in b
data In v a = MkIn (Expr v a) (Expr v a)
-- |
-- >>> var_ "a" `in_` [var_ "b", var_ "c"]
-- a in b, c
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_`
-- | @a and b@
--
-- Does not have a precedence
and_ :: Raw Expr -> Raw Expr -> Raw Expr
and_ a = BinOp (Ann ()) (a & trailingWhitespace .~ [Space]) (BoolAnd (Ann ()) [Space])
-- | @a or b@
--
-- Does not have a precedence
or_ :: Raw Expr -> Raw Expr -> Raw Expr
or_ a = BinOp (Ann ()) (a & trailingWhitespace .~ [Space]) (BoolOr (Ann ()) [Space])
-- |
-- >>> var_ "a" `in_` var_ "b"
-- a in b
instance InSyntax Expr (Raw Expr) where
in_ = mkBinOp $ In (Ann ())
-- | See 'for_'
instance e ~ Raw Expr => InSyntax InList [e] where
in_ = MkInList
-- | @a not in b@
notIn_ :: Raw Expr -> Raw Expr -> Raw Expr
notIn_ = mkBinOp $ NotIn (Ann ()) [Space]
infixl 1 `notIn_`
-- | @a is not b@
isNot_ :: Raw Expr -> Raw Expr -> Raw Expr
isNot_ = mkBinOp $ IsNot (Ann ()) [Space]
infixl 1 `isNot_`
-- | @not a@
not_ :: Raw Expr -> Raw Expr
not_ = Not (Ann ()) [Space]
-- | @a == b@
(.==) :: Raw Expr -> Raw Expr -> Raw Expr
(.==) = mkBinOp $ Eq (Ann ())
infixl 1 .==
-- | @a < b@
(.<) :: Raw Expr -> Raw Expr -> Raw Expr
(.<) = mkBinOp $ Lt (Ann ())
infixl 1 .<
-- | @a <= b@
(.<=) :: Raw Expr -> Raw Expr -> Raw Expr
(.<=) = mkBinOp $ LtEq (Ann ())
infixl 1 .<=
-- | @a > b@
(.>) :: Raw Expr -> Raw Expr -> Raw Expr
(.>) = mkBinOp $ Gt (Ann ())
infixl 1 .>
-- | @a >= b@
(.>=) :: Raw Expr -> Raw Expr -> Raw Expr
(.>=) = mkBinOp $ GtEq (Ann ())
infixl 1 .>=
-- | @a != b@
(.!=) :: Raw Expr -> Raw Expr -> Raw Expr
(.!=) = mkBinOp $ NotEq (Ann ())
infixl 1 .!=
-- | @a | b@
(.|) :: Raw Expr -> Raw Expr -> Raw Expr
(.|) = mkBinOp $ BitOr (Ann ())
infixl 2 .|
-- | @a ^ b@
(.^) :: Raw Expr -> Raw Expr -> Raw Expr
(.^) = mkBinOp $ BitXor (Ann ())
infixl 3 .^
-- | @a & b@
(.&) :: Raw Expr -> Raw Expr -> Raw Expr
(.&) = mkBinOp $ BitAnd (Ann ())
infixl 4 .&
-- | @a << b@
(.<<) :: Raw Expr -> Raw Expr -> Raw Expr
(.<<) = mkBinOp $ ShiftLeft (Ann ())
infixl 5 .<<
-- | @a >> b@
(.>>) :: Raw Expr -> Raw Expr -> Raw Expr
(.>>) = mkBinOp $ ShiftRight (Ann ())
infixl 5 .>>
-- | @a + b@
(.+) :: Raw Expr -> Raw Expr -> Raw Expr
(.+) = (+)
infixl 6 .+
-- | @a - b@
(.-) :: Raw Expr -> Raw Expr -> Raw Expr
(.-) = (-)
infixl 6 .-
-- | @a * b@
(.*) :: Raw Expr -> Raw Expr -> Raw Expr
(.*) = (*)
infixl 7 .*
-- | @a \@ b@
(.@) :: Raw Expr -> Raw Expr -> Raw Expr
(.@) = mkBinOp $ At (Ann ())
infixl 7 .@
-- | @a / b@
(./) :: Raw Expr -> Raw Expr -> Raw Expr
(./) = mkBinOp $ Divide (Ann ())
infixl 7 ./
-- | @a // b@
(.//) :: Raw Expr -> Raw Expr -> Raw Expr
(.//) = mkBinOp $ FloorDivide (Ann ())
infixl 7 .//
-- | @a % b@
(.%) :: Raw Expr -> Raw Expr -> Raw Expr
(.%) = mkBinOp $ Percent (Ann ())
infixl 7 .%
-- | @a ** b@
(.**) :: Raw Expr -> Raw Expr -> Raw Expr
(.**) = mkBinOp $ Exp (Ann ())
infixr 8 .**
-- |
-- >>> var_ "a" /> var_ "b"
-- a.b
(/>) :: Raw Expr -> Raw Ident -> Raw Expr
(/>) a = Deref (Ann ()) a []
infixl 9 />
-- | @-a@
neg_ :: Raw Expr -> Raw Expr
neg_ = negate
-- | @+a@
pos_ :: Raw Expr -> Raw Expr
pos_ = UnOp (Ann ()) (Positive (Ann ()) [])
-- | @~a@
compl_ :: Raw Expr -> Raw Expr
compl_ = UnOp (Ann ()) (Complement (Ann ()) [])
-- | Convert a list of 'Line's to a 'Block', giving them 4 spaces of indentation
linesToBlockIndented :: [Raw Line] -> Raw Block
linesToBlockIndented = over _Indents (indentIt $ replicate 4 Space) . linesToBlock
-- | Convert a list of 'Line's to a 'Block', without indenting them
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
-- | Create a minimal valid 'While'
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
-- | Create a minimal valid 'If'
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
-- |
-- @'if_' :: 'Raw' 'Expr' -> ['Raw' 'Line'] -> 'Raw' 'If'@
--
-- >>> if_ (var_ "a" .< 10) [var_ "a" .+= 1]
-- if a < 10:
-- a += 1
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_
-- None
none_ :: Raw Expr
none_ = None (Ann ()) []
-- | @'Raw' 'Expr'@ has a 'Num' instance, but sometimes we need to name integers
-- explicitly
--
-- >>> int_ 10
-- 10
int_ :: Integer -> Raw Expr
int_ = fromInteger
-- |
-- >>> pass_
-- pass
pass_ :: Raw Statement
pass_ =
SmallStatement
(Indents [] (Ann ()))
(MkSmallStatement (Pass (Ann ()) []) [] Nothing Nothing (Just LF))
-- | Create a minimal valid 'Elif'
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]
-- | Create a minimal valid 'Else'
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_
-- True
true_ :: Raw Expr
true_ = Bool (Ann ()) True []
-- |
-- >>> false_
-- False
false_ :: Raw Expr
false_ = Bool (Ann ()) False []
-- | Double-quoted string
--
-- >>> str_ "asdf"
-- "asdf"
str_ :: String -> Raw Expr
str_ s =
String (Ann ()) . pure $
StringLiteral (Ann ()) Nothing ShortString DoubleQuote (Char_lit <$> s) []
-- | Single-quoted string
--
-- >>> str_ "asdf"
-- 'asdf'
str'_ :: String -> Raw Expr
str'_ s =
String (Ann ()) . pure $
StringLiteral (Ann ()) Nothing ShortString SingleQuote (Char_lit <$> s) []
-- | Long double-quoted string
--
-- >>> longStr_ "asdf"
-- """asdf"""
longStr_ :: String -> Raw Expr
longStr_ s =
String (Ann ()) . pure $
StringLiteral (Ann ()) Nothing LongString DoubleQuote (Char_lit <$> s) []
-- | Long single-quoted string
--
-- >>> longStr'_ "asdf"
-- '''asdf'''
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))
-- | Chained assignment
--
-- >>> chainEq (var_ "a") []
-- a
--
-- >>> chainEq (var_ "a") [var_ "b", var_ "c"]
-- a = b = c
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))
-- | @a = b@
(.=) :: 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 .=
-- | @a += b@
(.+=) :: Raw Expr -> Raw Expr -> Raw Statement
(.+=) = mkAugAssign PlusEq
infix 0 .+=
-- | @a -= b@
(.-=) :: Raw Expr -> Raw Expr -> Raw Statement
(.-=) = mkAugAssign MinusEq
infix 0 .-=
-- | @a *= b@
(.*=) :: Raw Expr -> Raw Expr -> Raw Statement
(.*=) = mkAugAssign StarEq
infix 0 .*=
-- | @a @= b@
(.@=) :: Raw Expr -> Raw Expr -> Raw Statement
(.@=) = mkAugAssign AtEq
infix 0 .@=
-- | @a /= b@
(./=) :: Raw Expr -> Raw Expr -> Raw Statement
(./=) = mkAugAssign SlashEq
infix 0 ./=
-- | @a %= b@
(.%=) :: Raw Expr -> Raw Expr -> Raw Statement
(.%=) = mkAugAssign PercentEq
infix 0 .%=
-- | @a &= b@
(.&=) :: Raw Expr -> Raw Expr -> Raw Statement
(.&=) = mkAugAssign AmpersandEq
infix 0 .&=
-- | @a |= b@
(.|=) :: Raw Expr -> Raw Expr -> Raw Statement
(.|=) = mkAugAssign PipeEq
infix 0 .|=
-- | @a ^= b@
(.^=) :: Raw Expr -> Raw Expr -> Raw Statement
(.^=) = mkAugAssign CaretEq
infix 0 .^=
-- | @a <<= b@
(.<<=) :: Raw Expr -> Raw Expr -> Raw Statement
(.<<=) = mkAugAssign ShiftLeftEq
infix 0 .<<=
-- | @a >>= b@
(.>>=) :: Raw Expr -> Raw Expr -> Raw Statement
(.>>=) = mkAugAssign ShiftRightEq
infix 0 .>>=
-- | @a **= b@
(.**=) :: Raw Expr -> Raw Expr -> Raw Statement
(.**=) = mkAugAssign DoubleStarEq
infix 0 .**=
-- | @a //= b@
(.//=) :: 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
}
-- |
-- @'for_' :: 'Raw' 'InList' -> ['Raw' 'Line'] -> 'Raw' 'Statement'@
--
-- >>> for_ (var_ "a" `in_` [var_ "b"]) [line_ (var_ "c" .+= var_ "a")]
-- for a in b:
-- c += a
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
-- | Create a minimal valid 'Finally'
mkFinally :: [Raw Line] -> Raw Finally
mkFinally body =
MkFinally
{ _finallyIndents = Indents [] (Ann ())
, _finallyFinally = []
, _finallyBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
}
-- | Create a minimal valid 'Except'
mkExcept :: [Raw Line] -> Raw Except
mkExcept body =
MkExcept
{ _exceptIndents = Indents [] (Ann ())
, _exceptExcept = []
, _exceptExceptAs = Nothing
, _exceptBody = SuiteMany (Ann ()) (MkColon []) Nothing LF $ linesToBlockIndented body
}
-- | Create a minimal valid 'TryExcept'
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
}
-- | Create a minimal valid 'TryFinally'
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
-- |
-- >>> tryE_ [line_ pass_] & finally_ [line_ pass_]
-- try:
-- pass
-- finally:
-- pass
--
-- >>> tryF_ [line_ pass_] [line_ (a .+= 1)] & finally_ [line_ pass_]
-- try:
-- pass
-- finally:
-- pass
--
-- >>> tryF_ [line_ pass_] & finally_ [line_ pass_]
-- try:
-- pass
-- finally:
-- pass
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
-- | @try ... except@ with optional @else@ and optional @finally@
--
-- >>> tryE_ [line_ pass_] [line_ ("a" .+= 1)]
-- try:
-- pass
-- except
-- a += 1
tryE_ :: [Raw Line] -> Raw Except -> Raw TryExcept
tryE_ = mkTryExcept
instance BodySyntax TryFinally where
body = tfBody
body_ = mkBody_ tfIndents tfBody
-- |
-- @try ... finally@
--
-- >>> tryF_ [line_ pass_] [line_ ("a" .+= 1)]
-- try:
-- pass
-- finally:
-- a += 1
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
-- | You can use 'exceptAs_' without a binder:
--
-- @'exceptAs_' :: 'Raw' 'Expr' -> ['Raw' 'Line'] -> 'Raw' s -> 'Raw' 'TryExcept'@
--
-- @
-- 'exceptAs_' ('var_' \"Exception\") body
-- @
--
-- or with a binder:
--
-- @'exceptAs_' :: 'Raw' 'ExceptAs' -> ['Raw' 'Line'] -> 'Raw' s -> 'Raw' 'TryExcept'@
--
-- @
-- 'exceptAs_' ('var_' \"Exception\" \``as_`\` 'id_' "a") body
-- @
exceptAs_ :: AsExceptAs e => Raw e -> [Raw Line] -> s -> Raw TryExcept
-- |
-- @'except_' :: ['Raw' 'Line'] -> ('Raw' 'Except' -> 'Raw' 'TryExcept') -> 'Raw' 'TryExcept'@
--
-- @'exceptAs_' :: 'AsExceptAs' e => 'Raw' e -> ['Raw' 'Line'] -> ('Raw' 'Except' -> 'Raw' 'TryExcept') -> 'Raw' 'TryExcept'@
--
-- >>> tryE_ [var_ "a" .= 2] & except_ [var_ "a" .= 3]
-- try:
-- a = 2
-- except:
-- a = 3
--
-- >>> tryE_ [var_ "a" .= 2] & exceptAs_ (var_ "Exception" `as_` id_ "b") [var_ "a" .= 3]
-- try:
-- a = 2
-- except Exception as b:
-- a = 3
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
-- |
-- @'except_' :: ['Raw' 'Line'] -> 'Raw' 'TryExcept' -> 'Raw' 'TryExcept'@
--
-- @'exceptAs_' :: AsExceptAs => 'Raw' e -> ['Raw' 'Line'] -> 'Raw' 'TryExcept' -> 'Raw' 'TryExcept'@
--
-- @
-- (someTryStatement :: 'Raw' 'TryExcept') '&'
-- 'except_' ['line_' 'pass_']
-- @
--
-- @
-- (someTryStatement :: 'Raw' 'TryExcept') '&'
-- 'exceptAs_' ('var_' \"Exception\" \``as_`\` 'id_' "b") ['line_' 'pass_']
-- @
instance ExceptSyntax (Raw TryExcept) where
except_ body = teExcepts %~ (<> pure (mkExcept body))
exceptAs_ ea body =
teExcepts %~ (<> pure (mkExcept body & exceptExceptAs ?~ toExceptAs ea))
-- |
-- @'except_' :: ['Raw' 'Line'] -> 'Raw' 'TryFinally' -> 'Raw' 'TryExcept'@
--
-- @'exceptAs_' :: AsExceptAs => 'Raw' e -> ['Raw' 'Line'] -> 'Raw' 'TryFinally' -> 'Raw' 'TryExcept'@
--
-- @
-- (someTryStatement :: 'Raw' 'TryFinally') '&'
-- 'except_' ['line_' 'pass_']
-- @
--
-- @
-- (someTryStatement :: 'Raw' 'TryFinally') '&'
-- 'exceptAs_' ('var_' \"Exception\" \``as_`\` 'id_' "b") ['line_' 'pass_']
-- @
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
-- | See 'exceptAs_'
instance As Expr Ident ExceptAs where
as_ e name = ExceptAs (Ann ()) e $ Just ([Space], name)
-- |
-- >>> class_ "A" [] [line_ pass_]
-- class A:
-- pass
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', [])
}
-- | Create a minimal 'ClassDef'
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
-- | Create a minimal valid 'With'
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_ :: 'NonEmpty' ('Raw' 'Expr') -> ['Raw' 'Line'] -> 'Raw' 'Statement'
-- with_ :: 'NonEmpty' ('Raw' 'WithItem') -> ['Raw' 'Line'] -> 'Raw' 'Statement'
-- @
--
-- >>> with_ [var_ "a"] [line_ $ var_ "b"]
-- with a:
-- b
--
-- >>> with_ [var_ "a" `as_` id_ "name"] [line_ $ var_ "b"]
-- with a as name:
-- b
--
-- >>> with_ [withItem_ e Nothing] [line_ $ var_ "b"]
-- with a:
-- b
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)
-- | See 'with_'
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_
-- ...
ellipsis_ :: Raw Expr
ellipsis_ = Ellipsis (Ann ()) []
class AsTupleItem e where
-- | Create a 'TupleItem'
ti_ :: Raw e -> Raw TupleItem
-- | See 'tuple_'
instance StarSyntax Expr TupleItem where
s_ = TupleUnpack (Ann ()) [] []
instance AsTupleItem Expr where
ti_ = TupleItem (Ann ())
instance AsTupleItem TupleItem where
ti_ = id
-- |
-- >>> tuple_ []
-- ()
--
-- >>> tuple_ [ti_ $ var_ "a"]
-- a,
--
-- >>> tuple_ [s_ $ var_ "a"]
-- (*a),
--
-- >>> tuple_ [ti_ $ var_ "a", ti_ $ var_ "b"]
-- a, b
--
-- >>> tuple_ [ti_ $ var_ "a", s_ $ var_ "b"]
-- a, *b
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 (var_ "a")
-- await a
await_ :: Raw Expr -> Raw Expr
await_ = Await (Ann ()) [Space]
-- |
-- >>> ifThenElse_ (var_ "a") (var_ "b") (var_ "c")
-- a if b else c
ifThenElse_ :: Raw Expr -> Raw Expr -> Raw Expr -> Raw Expr
ifThenElse_ a b = Ternary (Ann ()) a [Space] b [Space]
-- |
-- >>> lambda_ [p_ "x"] "x"
-- lambda x: x
--
-- >>> lambda_ [p_ "x", k_ "y" 2] ("x" .+ "y")
-- lambda x, y=2: x + y
--
-- >>> lambda_ [p_ "x", k_ "y" 2, s_ "z"] "a"
-- lambda x, y=2, *z: a
--
-- >>> lambda_ [p_ "x", k_ "y" 2, s_ "z", ss_ "w"] "a"
-- lambda x, y=2, *z, **w: a
lambda_ :: [Raw Param] -> Raw Expr -> Raw Expr
lambda_ params =
Lambda (Ann ())
(if null params then [] else [Space])
(listToCommaSep params)
(MkColon [Space])
-- |
-- >>> yield_ []
-- yield
--
-- >>> yield_ [var_ "a"]
-- yield a
--
-- >>> yield_ [var_ "a", var_ "b"]
-- yield a, b
yield_ :: [Raw Expr] -> Raw Expr
yield_ as = Yield (Ann ()) (foldr (\_ _ -> [Space]) [] as) (listToCommaSep as)
-- |
-- >>> yieldFrom_ (var_ "a")
-- yield from a
yieldFrom_ :: Raw Expr -> Raw Expr
yieldFrom_ = YieldFrom (Ann ()) [Space] [Space]
-- | The slice with no bounds
--
-- >>> subs_ (var_ "a") fullSlice_
-- a[:]
--
-- >>> fullSlice_
-- slice(None, None, None)
fullSlice_ :: Raw Expr
fullSlice_ = slice_ Nothing Nothing Nothing
-- | Slice with *step* @x@
--
-- >>> subs_ (var_ "a") (sliceS_ $ int_ (-1))
-- a[::-1]
--
-- >>> sliceS_ $ int_ (-1)
-- slice(None, None, -1)
sliceS_ :: Raw Expr -> Raw Expr
sliceS_ x = slice_ Nothing Nothing (Just x)
-- | Slice *from* @x@
--
-- >>> subs_ (var_ "a") (sliceF_ $ int_ 0)
-- a[1:]
--
-- >>> sliceF_ $ int_ 0
-- slice(1, None, None)
sliceF_ :: Raw Expr -> Raw Expr
sliceF_ x = slice_ (Just x) Nothing Nothing
-- | Slice *from* @x@, with *step* @y@
--
-- >>> subs_ (var_ "a") (sliceFS_ (int_ 0) (int_ 2))
-- a[1::2]
--
-- >>> sliceFS_ (int_ 0) (int_ 2)
-- slice(1, None, 2)
sliceFS_ :: Raw Expr -> Raw Expr -> Raw Expr
sliceFS_ x y = slice_ (Just x) Nothing (Just y)
-- | Slice /To/ @x@
--
-- >>> subs_ (var_ "a") (sliceT_ $ int_ 10)
-- a[:10]
--
-- >>> sliceT_ $ int_ 10
-- slice(None, 10, None)
sliceT_ :: Raw Expr -> Raw Expr
sliceT_ x = slice_ Nothing (Just x) Nothing
-- | Slice /To/ @x@, with /Step/ @y@
--
-- >>> subs_ (var_ "a") (sliceTS_ (int_ 10) (int_ 2))
-- a[:10:2]
--
-- >>> sliceTS_ (int_ 10) (int_ 2)
-- slice(None, 10, 2)
sliceTS_ :: Raw Expr -> Raw Expr -> Raw Expr
sliceTS_ x y = slice_ Nothing (Just x) (Just y)
-- | Slice /From/ @x@ /To/ @y@
--
-- >>> subs_ (var_ "a") (sliceFT_ (int_ 1) (int_ 10))
-- a[1:10]
--
-- >>> sliceFT_ (int_ 1) (int_ 10)
-- slice(1, 10, None)
sliceFT_ :: Raw Expr -> Raw Expr -> Raw Expr
sliceFT_ x y = slice_ (Just x) (Just y) Nothing
-- | Slice /From/ @x@ /To/ @y@, with /Step/ @z@
--
-- >>> subs_ (var_ "a") (sliceFTS_ (int_ 1) (int_ 10) (int_ 2))
-- a[1:10:2]
--
-- >>> sliceFTS_ (int_ 1) (int_ 10) (int_ 2)
-- slice(1, 10, 2)
sliceFTS_ :: Raw Expr -> Raw Expr -> Raw Expr -> Raw Expr
sliceFTS_ x y z = slice_ (Just x) (Just y) (Just z)
-- | A slice object
--
-- Represents a call to a function named @slice@, with 3 arguments.
-- If an argument is a 'Nothing' then it becomes 'None', and if the argument is a
-- 'Just' then the contents are extracted.
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_ (var_ "a") (int_ 1)
-- a[1]
--
-- >>> subs_ (var_ "a") (tuple_ [ti_ $ int_ 1])
-- a[1,]
--
-- >>> subs_ (var_ "a") (tuple_ [ti_ $ int_ 1, ti_ $ int_ 2])
-- a[1, 2]
--
-- >>> subs_ (var_ "a") (tuple_ [s_ $ var_ "b"])
-- a[((*b),)]
--
-- >>> subs_ (var_ "a") (tuple_ [ti_ $ int_ 1, s_ $ var_ "b"])
-- a[(1, *b)]
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