-- | Desugars a reasonable amount of syntax to reduce duplication in code generation.
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE MonoLocalBinds        #-}

module Fay.Compiler.Desugar
  ( desugar
  , desugar'
  , desugarExpParen
  , desugarPatParen
  ) where

import           Fay.Compiler.Prelude

import           Fay.Compiler.Desugar.Name
import           Fay.Compiler.Desugar.Types
import           Fay.Compiler.Misc               (ffiExp, hasLanguagePragma)
import           Fay.Compiler.QName              (unQual, unname)
import           Fay.Exts.NoAnnotation           (unAnn)
import           Fay.Types                       (CompileError (..))

import           Control.Monad.Except            (throwError)
import           Control.Monad.Reader            (asks)
import qualified Data.Generics.Uniplate.Data     as U
import           Language.Haskell.Exts hiding (binds, loc, name)

-- | Top level, desugar a whole module possibly returning errors
desugar :: (Data l, Typeable l) => l -> Module l -> IO (Either CompileError (Module l))
desugar :: l -> Module l -> IO (Either CompileError (Module l))
desugar = String -> l -> Module l -> IO (Either CompileError (Module l))
forall l.
(Data l, Typeable l) =>
String -> l -> Module l -> IO (Either CompileError (Module l))
desugar' String
"$gen"

-- | Desugar with the option to specify a prefix for generated names.
-- Useful if you want to provide valid haskell names that HSE can print.
desugar' :: (Data l, Typeable l) => String -> l -> Module l -> IO (Either CompileError (Module l))
desugar' :: String -> l -> Module l -> IO (Either CompileError (Module l))
desugar' String
prefix l
emptyAnnotation Module l
md = String
-> l -> Desugar l (Module l) -> IO (Either CompileError (Module l))
forall l a.
String -> l -> Desugar l a -> IO (Either CompileError a)
runDesugar String
prefix l
emptyAnnotation (Desugar l (Module l) -> IO (Either CompileError (Module l)))
-> Desugar l (Module l) -> IO (Either CompileError (Module l))
forall a b. (a -> b) -> a -> b
$
      Module l -> Desugar l ()
forall l. (Data l, Typeable l) => Module l -> Desugar l ()
checkEnum Module l
md
  Desugar l () -> Desugar l (Module l) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarSection Module l
md
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarListComp
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarTupleCon
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> (Module l -> Module l) -> Module l -> Desugar l (Module l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module l -> Module l
forall l. (Data l, Typeable l) => Module l -> Module l
desugarPatParen
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> (Module l -> Module l) -> Module l -> Desugar l (Module l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module l -> Module l
forall l. (Data l, Typeable l) => Module l -> Module l
desugarFieldPun
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> (Module l -> Module l) -> Module l -> Desugar l (Module l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module l -> Module l
forall l. (Data l, Typeable l) => Module l -> Module l
desugarPatFieldPun
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarDo
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarTupleSection
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarImplicitPrelude
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarFFITypeSigs
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarLCase
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> (Module l -> Module l) -> Module l -> Desugar l (Module l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module l -> Module l
forall l. (Data l, Typeable l) => Module l -> Module l
desugarMultiIf
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> (Module l -> Module l) -> Module l -> Desugar l (Module l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module l -> Module l
forall l. (Data l, Typeable l) => Module l -> Module l
desugarInfixOp
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> (Module l -> Module l) -> Module l -> Desugar l (Module l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module l -> Module l
forall l. (Data l, Typeable l) => Module l -> Module l
desugarInfixPat
  Desugar l (Module l)
-> (Module l -> Desugar l (Module l)) -> Desugar l (Module l)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> (Module l -> Module l) -> Module l -> Desugar l (Module l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module l -> Module l
forall l. (Data l, Typeable l) => Module l -> Module l
desugarExpParen
{-# ANN desugar' "HLint: ignore Use <$>" #-}

-- | (a `f`) => \b -> a `f` b
--   (`f` b) => \a -> a `f` b
desugarSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarSection :: Module l -> Desugar l (Module l)
desugarSection = (Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l)
forall (m :: * -> *) (from :: * -> *) a (to :: * -> *).
(Monad m, Biplate (from a) (to a)) =>
(to a -> m (to a)) -> from a -> m (from a)
transformBiM ((Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l))
-> (Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l)
forall a b. (a -> b) -> a -> b
$ \Exp l
ex -> case Exp l
ex of
  LeftSection  l
l Exp l
e QOp l
q -> l -> (Name l -> Desugar l (Exp l)) -> Desugar l (Exp l)
forall l a.
(Data l, Typeable l) =>
l -> (Name l -> Desugar l a) -> Desugar l a
withScopedTmpName l
l ((Name l -> Desugar l (Exp l)) -> Desugar l (Exp l))
-> (Name l -> Desugar l (Exp l)) -> Desugar l (Exp l)
forall a b. (a -> b) -> a -> b
$ \Name l
tmp ->
      Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp l -> Desugar l (Exp l)) -> Exp l -> Desugar l (Exp l)
forall a b. (a -> b) -> a -> b
$ l -> [Pat l] -> Exp l -> Exp l
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda l
l [l -> Name l -> Pat l
forall l. l -> Name l -> Pat l
PVar l
l Name l
tmp] (l -> Exp l -> QOp l -> Exp l -> Exp l
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp l
l Exp l
e QOp l
q (l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Var l
l (l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l Name l
tmp)))
  RightSection l
l QOp l
q Exp l
e -> l -> (Name l -> Desugar l (Exp l)) -> Desugar l (Exp l)
forall l a.
(Data l, Typeable l) =>
l -> (Name l -> Desugar l a) -> Desugar l a
withScopedTmpName l
l ((Name l -> Desugar l (Exp l)) -> Desugar l (Exp l))
-> (Name l -> Desugar l (Exp l)) -> Desugar l (Exp l)
forall a b. (a -> b) -> a -> b
$ \Name l
tmp ->
      Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp l -> Desugar l (Exp l)) -> Exp l -> Desugar l (Exp l)
forall a b. (a -> b) -> a -> b
$ l -> [Pat l] -> Exp l -> Exp l
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda l
l [l -> Name l -> Pat l
forall l. l -> Name l -> Pat l
PVar l
l Name l
tmp] (l -> Exp l -> QOp l -> Exp l -> Exp l
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp l
l (l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Var l
l (l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l Name l
tmp)) QOp l
q Exp l
e)
  Exp l
_ -> Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return Exp l
ex

-- | Convert do notation into binds and thens.
desugarDo :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarDo :: Module l -> Desugar l (Module l)
desugarDo = (Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l)
forall (m :: * -> *) (from :: * -> *) a (to :: * -> *).
(Monad m, Biplate (from a) (to a)) =>
(to a -> m (to a)) -> from a -> m (from a)
transformBiM ((Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l))
-> (Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l)
forall a b. (a -> b) -> a -> b
$ \Exp l
ex -> case Exp l
ex of
  Do l
_ [Stmt l]
stmts -> Desugar l (Exp l)
-> (Exp l -> Desugar l (Exp l))
-> Maybe (Exp l)
-> Desugar l (Exp l)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CompileError -> Desugar l (Exp l)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CompileError
EmptyDoBlock) Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Exp l) -> Desugar l (Exp l))
-> Maybe (Exp l) -> Desugar l (Exp l)
forall a b. (a -> b) -> a -> b
$ (Maybe (Exp l) -> Stmt l -> Maybe (Exp l))
-> Maybe (Exp l) -> [Stmt l] -> Maybe (Exp l)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe (Exp l) -> Stmt l -> Maybe (Exp l)
forall l. Maybe (Exp l) -> Stmt l -> Maybe (Exp l)
desugarStmt' Maybe (Exp l)
forall a. Maybe a
Nothing ([Stmt l] -> [Stmt l]
forall a. [a] -> [a]
reverse [Stmt l]
stmts)
  Exp l
_ -> Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return Exp l
ex

desugarStmt' :: Maybe (Exp l) -> Stmt l -> Maybe (Exp l)
desugarStmt' :: Maybe (Exp l) -> Stmt l -> Maybe (Exp l)
desugarStmt' Maybe (Exp l)
inner Stmt l
stmt =
  Maybe (Exp l)
-> (Exp l -> Maybe (Exp l)) -> Maybe (Exp l) -> Maybe (Exp l)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (Exp l)
initStmt Exp l -> Maybe (Exp l)
subsequentStmt Maybe (Exp l)
inner
  where
    initStmt :: Maybe (Exp l)
initStmt = case Stmt l
stmt of
      Qualifier l
_ Exp l
exp -> Exp l -> Maybe (Exp l)
forall a. a -> Maybe a
Just Exp l
exp
      LetStmt{}     -> String -> Maybe (Exp l)
forall a. HasCallStack => String -> a
error String
"UnsupportedLet"
      Stmt l
_             -> String -> Maybe (Exp l)
forall a. HasCallStack => String -> a
error String
"InvalidDoBlock"

    subsequentStmt :: Exp l -> Maybe (Exp l)
subsequentStmt Exp l
inner' = case Stmt l
stmt of
      Generator l
loc Pat l
pat Exp l
exp -> l -> Pat l -> Exp l -> Exp l -> Maybe (Exp l)
forall l. l -> Pat l -> Exp l -> Exp l -> Maybe (Exp l)
desugarGenerator l
loc Pat l
pat Exp l
inner' Exp l
exp
      Qualifier l
s Exp l
exp -> Exp l -> Maybe (Exp l)
forall a. a -> Maybe a
Just (Exp l -> Maybe (Exp l)) -> Exp l -> Maybe (Exp l)
forall a b. (a -> b) -> a -> b
$ l -> Exp l -> QOp l -> Exp l -> Exp l
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp l
s Exp l
exp
                                         (l -> QName l -> QOp l
forall l. l -> QName l -> QOp l
QVarOp l
s (QName l -> QOp l) -> QName l -> QOp l
forall a b. (a -> b) -> a -> b
$ l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
s (Name l -> QName l) -> Name l -> QName l
forall a b. (a -> b) -> a -> b
$ l -> String -> Name l
forall l. l -> String -> Name l
Symbol l
s String
">>")
                                         Exp l
inner'
      LetStmt l
_ (BDecls l
s [Decl l]
binds) -> Exp l -> Maybe (Exp l)
forall a. a -> Maybe a
Just (Exp l -> Maybe (Exp l)) -> Exp l -> Maybe (Exp l)
forall a b. (a -> b) -> a -> b
$ l -> Binds l -> Exp l -> Exp l
forall l. l -> Binds l -> Exp l -> Exp l
Let l
s (l -> [Decl l] -> Binds l
forall l. l -> [Decl l] -> Binds l
BDecls l
s [Decl l]
binds) Exp l
inner'
      LetStmt l
_ Binds l
_ -> String -> Maybe (Exp l)
forall a. HasCallStack => String -> a
error String
"UnsupportedLet"
      RecStmt{} -> String -> Maybe (Exp l)
forall a. HasCallStack => String -> a
error String
"UnsupportedRecursiveDo"

    desugarGenerator :: l -> Pat l -> Exp l -> Exp l -> Maybe (Exp l)
    desugarGenerator :: l -> Pat l -> Exp l -> Exp l -> Maybe (Exp l)
desugarGenerator l
s Pat l
pat Exp l
inner' Exp l
exp =
      Exp l -> Maybe (Exp l)
forall a. a -> Maybe a
Just (Exp l -> Maybe (Exp l)) -> Exp l -> Maybe (Exp l)
forall a b. (a -> b) -> a -> b
$ l -> Exp l -> QOp l -> Exp l -> Exp l
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
InfixApp l
s
                      Exp l
exp
                      (l -> QName l -> QOp l
forall l. l -> QName l -> QOp l
QVarOp l
s (QName l -> QOp l) -> QName l -> QOp l
forall a b. (a -> b) -> a -> b
$ l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
s (Name l -> QName l) -> Name l -> QName l
forall a b. (a -> b) -> a -> b
$ l -> String -> Name l
forall l. l -> String -> Name l
Symbol l
s String
">>=")
                      (l -> [Pat l] -> Exp l -> Exp l
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda l
s [Pat l
pat] Exp l
inner')

-- | (,)  => \x y   -> (x,y)
--   (,,) => \x y z -> (x,y,z)
-- etc
desugarTupleCon :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarTupleCon :: Module l -> Desugar l (Module l)
desugarTupleCon Module l
md = do
  String
prefix <- (DesugarReader l -> String) -> Desugar l String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DesugarReader l -> String
forall l. DesugarReader l -> String
readerTmpNamePrefix
  Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> Module l -> Desugar l (Module l)
forall a b. (a -> b) -> a -> b
$ ((Exp l -> Exp l) -> Module l -> Module l)
-> Module l -> (Exp l -> Exp l) -> Module l
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Exp l -> Exp l) -> Module l -> Module l
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
(to a -> to a) -> from a -> from a
transformBi Module l
md ((Exp l -> Exp l) -> Module l) -> (Exp l -> Exp l) -> Module l
forall a b. (a -> b) -> a -> b
$ \Exp l
ex -> case Exp l
ex of
    Var l
_ (Special l
_ t :: SpecialCon l
t@TupleCon{}) -> String -> Exp l -> SpecialCon l -> Exp l
forall l. String -> Exp l -> SpecialCon l -> Exp l
fromTupleCon String
prefix Exp l
ex SpecialCon l
t
    Con l
_ (Special l
_ t :: SpecialCon l
t@TupleCon{}) -> String -> Exp l -> SpecialCon l -> Exp l
forall l. String -> Exp l -> SpecialCon l -> Exp l
fromTupleCon String
prefix Exp l
ex SpecialCon l
t
    Exp l
_ -> Exp l
ex
  where
    fromTupleCon :: String -> Exp l -> SpecialCon l -> Exp l
    fromTupleCon :: String -> Exp l -> SpecialCon l -> Exp l
fromTupleCon String
prefix Exp l
e SpecialCon l
s = Exp l -> Maybe (Exp l) -> Exp l
forall a. a -> Maybe a -> a
fromMaybe Exp l
e (Maybe (Exp l) -> Exp l) -> Maybe (Exp l) -> Exp l
forall a b. (a -> b) -> a -> b
$ case SpecialCon l
s of
      TupleCon l
l Boxed
b Int
n -> Exp l -> Maybe (Exp l)
forall a. a -> Maybe a
Just (Exp l -> Maybe (Exp l)) -> Exp l -> Maybe (Exp l)
forall a b. (a -> b) -> a -> b
$ l -> [Pat l] -> Exp l -> Exp l
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda l
l [Pat l]
params Exp l
body
        where
          -- It doesn't matter if these variable names shadow anything since
          -- this lambda won't have inner scopes.
          names :: [Name l]
names  = Int -> [Name l] -> [Name l]
forall a. Int -> [a] -> [a]
take Int
n ([Name l] -> [Name l]) -> [Name l] -> [Name l]
forall a b. (a -> b) -> a -> b
$ l -> String -> [Name l]
forall l. l -> String -> [Name l]
unscopedTmpNames l
l String
prefix
          params :: [Pat l]
params = l -> Name l -> Pat l
forall l. l -> Name l -> Pat l
PVar l
l (Name l -> Pat l) -> [Name l] -> [Pat l]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name l]
names
          body :: Exp l
body   = l -> Boxed -> [Exp l] -> Exp l
forall l. l -> Boxed -> [Exp l] -> Exp l
Tuple l
l Boxed
b (l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Var l
l (QName l -> Exp l) -> (Name l -> QName l) -> Name l -> Exp l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l (Name l -> Exp l) -> [Name l] -> [Exp l]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name l]
names)
      SpecialCon l
_ -> Maybe (Exp l)
forall a. Maybe a
Nothing

-- | \case { ... } => \foo -> case foo of { ... }
desugarLCase :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarLCase :: Module l -> Desugar l (Module l)
desugarLCase = (Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l)
forall (m :: * -> *) (from :: * -> *) a (to :: * -> *).
(Monad m, Biplate (from a) (to a)) =>
(to a -> m (to a)) -> from a -> m (from a)
transformBiM ((Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l))
-> (Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l)
forall a b. (a -> b) -> a -> b
$ \Exp l
ex -> case Exp l
ex of
  LCase l
l [Alt l]
alts -> l -> (Name l -> Desugar l (Exp l)) -> Desugar l (Exp l)
forall l a.
(Data l, Typeable l) =>
l -> (Name l -> Desugar l a) -> Desugar l a
withScopedTmpName l
l ((Name l -> Desugar l (Exp l)) -> Desugar l (Exp l))
-> (Name l -> Desugar l (Exp l)) -> Desugar l (Exp l)
forall a b. (a -> b) -> a -> b
$ \Name l
n -> Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp l -> Desugar l (Exp l)) -> Exp l -> Desugar l (Exp l)
forall a b. (a -> b) -> a -> b
$ l -> [Pat l] -> Exp l -> Exp l
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda l
l [l -> Name l -> Pat l
forall l. l -> Name l -> Pat l
PVar l
l Name l
n] (l -> Exp l -> [Alt l] -> Exp l
forall l. l -> Exp l -> [Alt l] -> Exp l
Case l
l (l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Var l
l (l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l Name l
n)) [Alt l]
alts)
  Exp l
_ -> Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return Exp l
ex

-- | if | p -> x | q -> y => case () of _ | p -> x | q -> y
desugarMultiIf :: (Data l, Typeable l) => Module l -> Module l
desugarMultiIf :: Module l -> Module l
desugarMultiIf = (Exp l -> Exp l) -> Module l -> Module l
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
(to a -> to a) -> from a -> from a
transformBi ((Exp l -> Exp l) -> Module l -> Module l)
-> (Exp l -> Exp l) -> Module l -> Module l
forall a b. (a -> b) -> a -> b
$ \Exp l
ex -> case Exp l
ex of
  MultiIf l
l [GuardedRhs l]
alts -> l -> Exp l -> [Alt l] -> Exp l
forall l. l -> Exp l -> [Alt l] -> Exp l
Case l
l (l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Con l
l (l -> SpecialCon l -> QName l
forall l. l -> SpecialCon l -> QName l
Special l
l (l -> SpecialCon l
forall l. l -> SpecialCon l
UnitCon l
l)))
                           [l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt l
l (l -> Pat l
forall l. l -> Pat l
PWildCard l
l) (l -> [GuardedRhs l] -> Rhs l
forall l. l -> [GuardedRhs l] -> Rhs l
GuardedRhss l
l [GuardedRhs l]
alts) Maybe (Binds l)
forall a. Maybe a
Nothing]
  Exp l
_ -> Exp l
ex

-- | (a,) => \b -> (a,b)
desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarTupleSection :: Module l -> Desugar l (Module l)
desugarTupleSection Module l
md = do
  String
prefix <- (DesugarReader l -> String) -> Desugar l String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DesugarReader l -> String
forall l. DesugarReader l -> String
readerTmpNamePrefix
  ((Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l))
-> Module l -> (Exp l -> Desugar l (Exp l)) -> Desugar l (Module l)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l)
forall (m :: * -> *) (from :: * -> *) a (to :: * -> *).
(Monad m, Biplate (from a) (to a)) =>
(to a -> m (to a)) -> from a -> m (from a)
transformBiM Module l
md ((Exp l -> Desugar l (Exp l)) -> Desugar l (Module l))
-> (Exp l -> Desugar l (Exp l)) -> Desugar l (Module l)
forall a b. (a -> b) -> a -> b
$ \Exp l
ex -> case Exp l
ex of
    TupleSection l
l Boxed
_ [Maybe (Exp l)]
mes -> do
      ([Name l]
names, [Exp l]
lst) <- l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])
forall l.
l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])
genSlotNames l
l [Maybe (Exp l)]
mes (l -> String -> [Name l]
forall l. l -> String -> [Name l]
unscopedTmpNames l
l String
prefix)
      Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp l -> Desugar l (Exp l)) -> Exp l -> Desugar l (Exp l)
forall a b. (a -> b) -> a -> b
$ l -> [Pat l] -> Exp l -> Exp l
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda l
l ((Name l -> Pat l) -> [Name l] -> [Pat l]
forall a b. (a -> b) -> [a] -> [b]
map (l -> Name l -> Pat l
forall l. l -> Name l -> Pat l
PVar l
l) [Name l]
names) (l -> Boxed -> [Exp l] -> Exp l
forall l. l -> Boxed -> [Exp l] -> Exp l
Tuple l
l Boxed
Boxed [Exp l]
lst)
    Exp l
_ -> Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return Exp l
ex
  where

    genSlotNames :: l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])
    genSlotNames :: l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])
genSlotNames l
_ [] [Name l]
_ = ([Name l], [Exp l]) -> Desugar l ([Name l], [Exp l])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    genSlotNames l
l (Maybe (Exp l)
Nothing : [Maybe (Exp l)]
rest) [Name l]
ns = do
      -- it's safe to use head/tail here because ns is an infinite list
      ([Name l]
rn, [Exp l]
re) <- l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])
forall l.
l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])
genSlotNames l
l [Maybe (Exp l)]
rest ([Name l] -> [Name l]
forall a. [a] -> [a]
tail [Name l]
ns)
      ([Name l], [Exp l]) -> Desugar l ([Name l], [Exp l])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name l] -> Name l
forall a. [a] -> a
head [Name l]
ns Name l -> [Name l] -> [Name l]
forall a. a -> [a] -> [a]
: [Name l]
rn, l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Var l
l (l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l ([Name l] -> Name l
forall a. [a] -> a
head [Name l]
ns)) Exp l -> [Exp l] -> [Exp l]
forall a. a -> [a] -> [a]
: [Exp l]
re)
    genSlotNames l
l (Just Exp l
e : [Maybe (Exp l)]
rest) [Name l]
ns = do
      ([Name l]
rn, [Exp l]
re) <- l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])
forall l.
l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])
genSlotNames l
l [Maybe (Exp l)]
rest [Name l]
ns
      ([Name l], [Exp l]) -> Desugar l ([Name l], [Exp l])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name l]
rn, Exp l
e Exp l -> [Exp l] -> [Exp l]
forall a. a -> [a] -> [a]
: [Exp l]
re)

-- (p) => p for patterns
desugarPatParen :: (Data l, Typeable l) => Module l -> Module l
desugarPatParen :: Module l -> Module l
desugarPatParen = (Pat l -> Pat l) -> Module l -> Module l
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
(to a -> to a) -> from a -> from a
transformBi ((Pat l -> Pat l) -> Module l -> Module l)
-> (Pat l -> Pat l) -> Module l -> Module l
forall a b. (a -> b) -> a -> b
$ \Pat l
pt -> case Pat l
pt of
  PParen l
_ Pat l
p -> Pat l
p
  Pat l
_ -> Pat l
pt

-- | {a} => {a=a} for R{a} expressions
desugarFieldPun :: (Data l, Typeable l) => Module l -> Module l
desugarFieldPun :: Module l -> Module l
desugarFieldPun = (FieldUpdate l -> FieldUpdate l) -> Module l -> Module l
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
(to a -> to a) -> from a -> from a
transformBi ((FieldUpdate l -> FieldUpdate l) -> Module l -> Module l)
-> (FieldUpdate l -> FieldUpdate l) -> Module l -> Module l
forall a b. (a -> b) -> a -> b
$ \FieldUpdate l
f -> case FieldUpdate l
f of
  FieldPun l
l QName l
n -> l -> QName l -> Exp l -> FieldUpdate l
forall l. l -> QName l -> Exp l -> FieldUpdate l
FieldUpdate l
l QName l
n (l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Var l
l QName l
n)
  FieldUpdate l
_ -> FieldUpdate l
f

-- | {a} => {a=a} for R{a} patterns
desugarPatFieldPun :: (Data l, Typeable l) => Module l -> Module l
desugarPatFieldPun :: Module l -> Module l
desugarPatFieldPun = (PatField l -> PatField l) -> Module l -> Module l
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
(to a -> to a) -> from a -> from a
transformBi ((PatField l -> PatField l) -> Module l -> Module l)
-> (PatField l -> PatField l) -> Module l -> Module l
forall a b. (a -> b) -> a -> b
$ \PatField l
pf -> case PatField l
pf of
  PFieldPun l
l QName l
n -> l -> QName l -> Pat l -> PatField l
forall l. l -> QName l -> Pat l -> PatField l
PFieldPat l
l QName l
n (l -> Name l -> Pat l
forall l. l -> Name l -> Pat l
PVar l
l (QName l -> Name l
forall a. QName a -> Name a
unQual QName l
n))
  PatField l
_             -> PatField l
pf

-- | Desugar list comprehensions.
desugarListComp :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarListComp :: Module l -> Desugar l (Module l)
desugarListComp = (Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l)
forall (m :: * -> *) (from :: * -> *) a (to :: * -> *).
(Monad m, Biplate (from a) (to a)) =>
(to a -> m (to a)) -> from a -> m (from a)
transformBiM ((Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l))
-> (Exp l -> Desugar l (Exp l)) -> Module l -> Desugar l (Module l)
forall a b. (a -> b) -> a -> b
$ \Exp l
ex -> case Exp l
ex of
    ListComp l
l Exp l
exp [QualStmt l]
stmts -> l -> Exp l -> [QualStmt l] -> Desugar l (Exp l)
forall l. Data l => l -> Exp l -> [QualStmt l] -> Desugar l (Exp l)
desugarListComp' l
l Exp l
exp [QualStmt l]
stmts
    Exp l
_ -> Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return Exp l
ex
  where
    desugarListComp' :: l -> Exp l -> [QualStmt l] -> Desugar l (Exp l)
desugarListComp' l
l Exp l
e [] = Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> [Exp l] -> Exp l
forall l. l -> [Exp l] -> Exp l
List l
l [ Exp l
e ])
    desugarListComp' l
l Exp l
e (QualStmt l
_ (Generator l
_ Pat l
p Exp l
e2) : [QualStmt l]
stmts) = do
      Exp l
nested <- l -> Exp l -> [QualStmt l] -> Desugar l (Exp l)
desugarListComp' l
l Exp l
e [QualStmt l]
stmts
      l -> (Name l -> Desugar l (Exp l)) -> Desugar l (Exp l)
forall l a.
(Data l, Typeable l) =>
l -> (Name l -> Desugar l a) -> Desugar l a
withScopedTmpName l
l ((Name l -> Desugar l (Exp l)) -> Desugar l (Exp l))
-> (Name l -> Desugar l (Exp l)) -> Desugar l (Exp l)
forall a b. (a -> b) -> a -> b
$ \Name l
f ->
        Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> Binds l -> Exp l -> Exp l
forall l. l -> Binds l -> Exp l -> Exp l
Let l
l (l -> [Decl l] -> Binds l
forall l. l -> [Decl l] -> Binds l
BDecls l
l [ l -> [Match l] -> Decl l
forall l. l -> [Match l] -> Decl l
FunBind l
l [
            l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match l
l Name l
f [ Pat l
p           ] (l -> Exp l -> Rhs l
forall l. l -> Exp l -> Rhs l
UnGuardedRhs l
l Exp l
nested) Maybe (Binds l)
forall a. Maybe a
Nothing
          , l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match l
l Name l
f [ l -> Pat l
forall l. l -> Pat l
PWildCard l
l ] (l -> Exp l -> Rhs l
forall l. l -> Exp l -> Rhs l
UnGuardedRhs l
l (l -> [Exp l] -> Exp l
forall l. l -> [Exp l] -> Exp l
List l
l [])) Maybe (Binds l)
forall a. Maybe a
Nothing
          ]]) (l -> Exp l -> Exp l -> Exp l
forall l. l -> Exp l -> Exp l -> Exp l
App l
l (l -> Exp l -> Exp l -> Exp l
forall l. l -> Exp l -> Exp l -> Exp l
App l
l (l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Var l
l (l -> ModuleName l -> Name l -> QName l
forall l. l -> ModuleName l -> Name l -> QName l
Qual l
l (l -> String -> ModuleName l
forall l. l -> String -> ModuleName l
ModuleName l
l String
"$Prelude") (l -> String -> Name l
forall l. l -> String -> Name l
Ident l
l String
"concatMap"))) (l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Var l
l (l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l Name l
f))) Exp l
e2))
    desugarListComp' l
l Exp l
e (QualStmt l
_ (Qualifier l
_ Exp l
e2) : [QualStmt l]
stmts) = do
      Exp l
nested <- l -> Exp l -> [QualStmt l] -> Desugar l (Exp l)
desugarListComp' l
l Exp l
e [QualStmt l]
stmts
      Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> Exp l -> Exp l -> Exp l -> Exp l
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
If l
l Exp l
e2 Exp l
nested (l -> [Exp l] -> Exp l
forall l. l -> [Exp l] -> Exp l
List l
l []))
    desugarListComp' l
l Exp l
e (QualStmt l
_ (LetStmt l
_ Binds l
bs) : [QualStmt l]
stmts) = do
      Exp l
nested <- l -> Exp l -> [QualStmt l] -> Desugar l (Exp l)
desugarListComp' l
l Exp l
e [QualStmt l]
stmts
      Exp l -> Desugar l (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> Binds l -> Exp l -> Exp l
forall l. l -> Binds l -> Exp l -> Exp l
Let l
l Binds l
bs Exp l
nested)
    desugarListComp' l
_ Exp l
_ (QualStmt l
_ : [QualStmt l]
_) =
      String -> Desugar l (Exp l)
forall a. HasCallStack => String -> a
error String
"UnsupportedListComprehension"

-- | We only have Enum instance for Int, but GHC hard codes [x..y]
-- syntax to GHC.Base.Enum instead of using our Enum class so we check
-- for obviously incorrect usages and throw an error on them. This can
-- only checks literals, but it helps a bit.
checkEnum :: (Data l, Typeable l) => Module l -> Desugar l ()
checkEnum :: Module l -> Desugar l ()
checkEnum = (Exp l -> Desugar l ()) -> [Exp l] -> Desugar l ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Exp l -> Desugar l ()
forall l. Exp l -> Desugar l ()
f ([Exp l] -> Desugar l ())
-> (Module l -> [Exp l]) -> Module l -> Desugar l ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module l -> [Exp l]
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
from a -> [to a]
universeBi
  where
    f :: Exp l -> Desugar l ()
f Exp l
ex = case Exp l
ex of
      e :: Exp l
e@(EnumFrom       l
_ Exp l
e1)       -> Exp l -> [Exp l] -> Desugar l ()
forall l. Exp l -> [Exp l] -> Desugar l ()
checkIntOrUnknown Exp l
e [Exp l
e1]
      e :: Exp l
e@(EnumFromTo     l
_ Exp l
e1 Exp l
e2)    -> Exp l -> [Exp l] -> Desugar l ()
forall l. Exp l -> [Exp l] -> Desugar l ()
checkIntOrUnknown Exp l
e [Exp l
e1,Exp l
e2]
      e :: Exp l
e@(EnumFromThen   l
_ Exp l
e1 Exp l
e2)    -> Exp l -> [Exp l] -> Desugar l ()
forall l. Exp l -> [Exp l] -> Desugar l ()
checkIntOrUnknown Exp l
e [Exp l
e1,Exp l
e2]
      e :: Exp l
e@(EnumFromThenTo l
_ Exp l
e1 Exp l
e2 Exp l
e3) -> Exp l -> [Exp l] -> Desugar l ()
forall l. Exp l -> [Exp l] -> Desugar l ()
checkIntOrUnknown Exp l
e [Exp l
e1,Exp l
e2,Exp l
e3]
      Exp l
_ -> () -> Desugar l ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    checkIntOrUnknown :: Exp l -> [Exp l] -> Desugar l ()
    checkIntOrUnknown :: Exp l -> [Exp l] -> Desugar l ()
checkIntOrUnknown Exp l
exp [Exp l]
es = Bool -> Desugar l () -> Desugar l ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Exp l -> Bool) -> [Exp l] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Exp l -> Bool
forall l. Exp l -> Bool
isIntOrUnknown [Exp l]
es) (CompileError -> Desugar l ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Desugar l ())
-> (Exp -> CompileError) -> Exp -> Desugar l ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> CompileError
UnsupportedEnum (Exp -> Desugar l ()) -> Exp -> Desugar l ()
forall a b. (a -> b) -> a -> b
$ Exp l -> Exp
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Exp l
exp)
    isIntOrUnknown :: Exp l -> Bool
    isIntOrUnknown :: Exp l -> Bool
isIntOrUnknown Exp l
e = case Exp l
e of
      Con            {} -> Bool
False
      Lit l
_ Int{}       -> Bool
True
      Lit            {} -> Bool
False
      Tuple          {} -> Bool
False
      List           {} -> Bool
False
      EnumFrom       {} -> Bool
False
      EnumFromTo     {} -> Bool
False
      EnumFromThen   {} -> Bool
False
      EnumFromThenTo {} -> Bool
False
      Exp l
_                 -> Bool
True

-- | Adds an explicit import Prelude statement when appropriate.
desugarImplicitPrelude :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarImplicitPrelude :: Module l -> Desugar l (Module l)
desugarImplicitPrelude Module l
m =
    if Bool
preludeNotNeeded
        then Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return Module l
m
        else Module l -> Desugar l (Module l)
forall l. Module l -> Desugar l (Module l)
addPrelude Module l
m
  where
    preludeNotNeeded :: Bool
preludeNotNeeded = Module l -> Bool
forall l. Module l -> Bool
hasExplicitPrelude Module l
m Bool -> Bool -> Bool
||
                       String -> [ModulePragma l] -> Bool
forall l. String -> [ModulePragma l] -> Bool
hasLanguagePragma String
"NoImplicitPrelude" (Module l -> [ModulePragma l]
forall l. (Data l, Typeable l) => Module l -> [ModulePragma l]
getPragmas Module l
m)

    getPragmas :: (Data l, Typeable l) => Module l -> [ModulePragma l]
    getPragmas :: Module l -> [ModulePragma l]
getPragmas = Module l -> [ModulePragma l]
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
from a -> [to a]
universeBi

    getImportDecls :: Module l -> [ImportDecl l]
    getImportDecls :: Module l -> [ImportDecl l]
getImportDecls (Module l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
_ [ImportDecl l]
decls [Decl l]
_) = [ImportDecl l]
decls
    getImportDecls Module l
_ = []

    setImportDecls :: [ImportDecl l] -> Module l -> Module l
    setImportDecls :: [ImportDecl l] -> Module l -> Module l
setImportDecls [ImportDecl l]
decls (Module l
a Maybe (ModuleHead l)
b [ModulePragma l]
c [ImportDecl l]
_ [Decl l]
d) = l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Module l
a Maybe (ModuleHead l)
b [ModulePragma l]
c [ImportDecl l]
decls [Decl l]
d
    setImportDecls [ImportDecl l]
_ Module l
mod = Module l
mod

    hasExplicitPrelude :: Module l -> Bool
    hasExplicitPrelude :: Module l -> Bool
hasExplicitPrelude = (ImportDecl l -> Bool) -> [ImportDecl l] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ImportDecl l -> Bool
forall l. ImportDecl l -> Bool
isPrelude ([ImportDecl l] -> Bool)
-> (Module l -> [ImportDecl l]) -> Module l -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module l -> [ImportDecl l]
forall l. Module l -> [ImportDecl l]
getImportDecls

    isPrelude :: ImportDecl l -> Bool
    isPrelude :: ImportDecl l -> Bool
isPrelude ImportDecl l
decl = case ImportDecl l -> ModuleName l
forall l. ImportDecl l -> ModuleName l
importModule ImportDecl l
decl of
      ModuleName l
_ String
name -> String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Prelude"

    addPrelude :: Module l -> Desugar l (Module l)
    addPrelude :: Module l -> Desugar l (Module l)
addPrelude Module l
mod = do
      let decls :: [ImportDecl l]
decls = Module l -> [ImportDecl l]
forall l. Module l -> [ImportDecl l]
getImportDecls Module l
mod
      ImportDecl l
prelude <- Desugar l (ImportDecl l)
forall l. Desugar l (ImportDecl l)
getPrelude
      Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> Module l -> Desugar l (Module l)
forall a b. (a -> b) -> a -> b
$ [ImportDecl l] -> Module l -> Module l
forall l. [ImportDecl l] -> Module l -> Module l
setImportDecls (ImportDecl l
prelude ImportDecl l -> [ImportDecl l] -> [ImportDecl l]
forall a. a -> [a] -> [a]
: [ImportDecl l]
decls) Module l
mod

    getPrelude :: Desugar l (ImportDecl l)
    getPrelude :: Desugar l (ImportDecl l)
getPrelude = do
      l
noInfo <- (DesugarReader l -> l) -> Desugar l l
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DesugarReader l -> l
forall l. DesugarReader l -> l
readerNoInfo
      ImportDecl l -> Desugar l (ImportDecl l)
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportDecl l -> Desugar l (ImportDecl l))
-> ImportDecl l -> Desugar l (ImportDecl l)
forall a b. (a -> b) -> a -> b
$ l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
ImportDecl l
noInfo (l -> String -> ModuleName l
forall l. l -> String -> ModuleName l
ModuleName l
noInfo String
"Prelude") Bool
False Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing Maybe (ModuleName l)
forall a. Maybe a
Nothing Maybe (ImportSpecList l)
forall a. Maybe a
Nothing

desugarFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarFFITypeSigs :: Module l -> Desugar l (Module l)
desugarFFITypeSigs = Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarToplevelFFITypeSigs (Module l -> Desugar l (Module l))
-> (Module l -> Desugar l (Module l))
-> Module l
-> Desugar l (Module l)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Module l -> Desugar l (Module l)
forall l. (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarBindsTypeSigs

-- | For each toplevel FFI pattern binding, search the module for the relevant
-- type declaration; if found, add a type signature to the ffi expression.
-- e.g.
--  foo :: Int
--  foo = ffi "3"
-- becomes
--  foo :: Int
--  foo = ffi "3" :: Int
desugarToplevelFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarToplevelFFITypeSigs :: Module l -> Desugar l (Module l)
desugarToplevelFFITypeSigs Module l
m = case Module l
m of
  Module l
a Maybe (ModuleHead l)
b [ModulePragma l]
c [ImportDecl l]
d [Decl l]
decls -> do
    [Decl l]
decls' <- [Decl l] -> Desugar l [Decl l]
forall l. (Data l, Typeable l) => [Decl l] -> Desugar l [Decl l]
addFFIExpTypeSigs [Decl l]
decls
    Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module l -> Desugar l (Module l))
-> Module l -> Desugar l (Module l)
forall a b. (a -> b) -> a -> b
$ l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Module l
a Maybe (ModuleHead l)
b [ModulePragma l]
c [ImportDecl l]
d [Decl l]
decls'
  Module l
_ -> Module l -> Desugar l (Module l)
forall (m :: * -> *) a. Monad m => a -> m a
return Module l
m

desugarBindsTypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarBindsTypeSigs :: Module l -> Desugar l (Module l)
desugarBindsTypeSigs = (Binds l -> Desugar l (Binds l))
-> Module l -> Desugar l (Module l)
forall (m :: * -> *) (from :: * -> *) a (to :: * -> *).
(Monad m, Biplate (from a) (to a)) =>
(to a -> m (to a)) -> from a -> m (from a)
transformBiM ((Binds l -> Desugar l (Binds l))
 -> Module l -> Desugar l (Module l))
-> (Binds l -> Desugar l (Binds l))
-> Module l
-> Desugar l (Module l)
forall a b. (a -> b) -> a -> b
$ \(BDecls l
srcInfo [Decl l]
decls) -> do
  [Decl l]
decls' <- [Decl l] -> Desugar l [Decl l]
forall l. (Data l, Typeable l) => [Decl l] -> Desugar l [Decl l]
addFFIExpTypeSigs [Decl l]
decls
  Binds l -> Desugar l (Binds l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Binds l -> Desugar l (Binds l)) -> Binds l -> Desugar l (Binds l)
forall a b. (a -> b) -> a -> b
$ l -> [Decl l] -> Binds l
forall l. l -> [Decl l] -> Binds l
BDecls l
srcInfo [Decl l]
decls'

addFFIExpTypeSigs :: (Data l, Typeable l) => [Decl l] -> Desugar l [Decl l]
addFFIExpTypeSigs :: [Decl l] -> Desugar l [Decl l]
addFFIExpTypeSigs [Decl l]
decls = do
  let typeSigs :: [(String, Type l)]
typeSigs = [Decl l] -> [(String, Type l)]
forall a. [Decl a] -> [(String, Type a)]
getTypeSigs [Decl l]
decls
  [Desugar l (Decl l)] -> Desugar l [Decl l]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Desugar l (Decl l)] -> Desugar l [Decl l])
-> [Desugar l (Decl l)] -> Desugar l [Decl l]
forall a b. (a -> b) -> a -> b
$ [(String, Type l)] -> [Decl l] -> [Desugar l (Decl l)]
forall l (m :: * -> *).
MonadReader (DesugarReader l) m =>
[(String, Type l)] -> [Decl l] -> [m (Decl l)]
go [(String, Type l)]
typeSigs [Decl l]
decls
  where
  -- | Create a lookup list mapping names to types, for all the types declared
  -- through standalone (ie: not in an expression) type signatures at this
  -- scope level.
  getTypeSigs :: [Decl a] -> [(String, Type a)]
getTypeSigs [Decl a]
ds = [ (Name a -> String
forall a. Name a -> String
unname Name a
n, Type a
typ) | TypeSig a
_ [Name a]
names Type a
typ <- [Decl a]
ds, Name a
n <- [Name a]
names ]

  go :: [(String, Type l)] -> [Decl l] -> [m (Decl l)]
go [(String, Type l)]
typeSigs = (Decl l -> m (Decl l)) -> [Decl l] -> [m (Decl l)]
forall a b. (a -> b) -> [a] -> [b]
map ([(String, Type l)] -> Decl l -> m (Decl l)
forall (m :: * -> *) l.
MonadReader (DesugarReader l) m =>
[(String, Type l)] -> Decl l -> m (Decl l)
addTypeSig [(String, Type l)]
typeSigs)

  addTypeSig :: [(String, Type l)] -> Decl l -> m (Decl l)
addTypeSig [(String, Type l)]
typeSigs Decl l
decl = case Decl l
decl of
    (PatBind l
loc Pat l
pat Rhs l
rhs Maybe (Binds l)
binds) ->
      case Rhs l -> Maybe (l, Exp l)
forall a. Rhs a -> Maybe (a, Exp a)
getUnguardedRhs Rhs l
rhs of
        Just (l
srcInfo, Exp l
rhExp) ->
          if Exp l -> Bool
forall l. Exp l -> Bool
isFFI Exp l
rhExp
            then do
              Exp l
rhExp' <- [(String, Type l)] -> Decl l -> Exp l -> m (Exp l)
forall (m :: * -> *) l a.
MonadReader (DesugarReader l) m =>
[(String, Type l)] -> Decl a -> Exp l -> m (Exp l)
addSigToExp [(String, Type l)]
typeSigs Decl l
decl Exp l
rhExp
              Decl l -> m (Decl l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl l -> m (Decl l)) -> Decl l -> m (Decl l)
forall a b. (a -> b) -> a -> b
$ l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind l
loc Pat l
pat (l -> Exp l -> Rhs l
forall l. l -> Exp l -> Rhs l
UnGuardedRhs l
srcInfo Exp l
rhExp') Maybe (Binds l)
binds
            else Decl l -> m (Decl l)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl l
decl
        Maybe (l, Exp l)
_ -> Decl l -> m (Decl l)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl l
decl
    Decl l
_ -> Decl l -> m (Decl l)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl l
decl

  getUnguardedRhs :: Rhs a -> Maybe (a, Exp a)
getUnguardedRhs Rhs a
rhs = case Rhs a
rhs of
    (UnGuardedRhs a
srcInfo Exp a
exp) -> (a, Exp a) -> Maybe (a, Exp a)
forall a. a -> Maybe a
Just (a
srcInfo, Exp a
exp)
    Rhs a
_ -> Maybe (a, Exp a)
forall a. Maybe a
Nothing

  isFFI :: Exp a -> Bool
isFFI = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> (Exp a -> Maybe String) -> Exp a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp a -> Maybe String
forall a. Exp a -> Maybe String
ffiExp

  -- | Adds an explicit type signature to an expression (which is assumed to
  -- be the RHS of a declaration). This should only need to be called for FFI
  -- function declarations.
  -- Arguments:
  --  sigs:  List of toplevel type signatures
  --  decl:  The declaration, which should be a PatBind.
  --  rhExp: Expression comprising the RHS of the declaration
  addSigToExp :: [(String, Type l)] -> Decl a -> Exp l -> m (Exp l)
addSigToExp [(String, Type l)]
typeSigs Decl a
decl Exp l
rhExp = case [(String, Type l)] -> Decl a -> Maybe (Type l)
forall b a. [(String, b)] -> Decl a -> Maybe b
getTypeFor [(String, Type l)]
typeSigs Decl a
decl of
    Just Type l
typ -> do
      l
noInfo <- (DesugarReader l -> l) -> m l
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DesugarReader l -> l
forall l. DesugarReader l -> l
readerNoInfo
      Exp l -> m (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp l -> m (Exp l)) -> Exp l -> m (Exp l)
forall a b. (a -> b) -> a -> b
$ l -> Exp l -> Type l -> Exp l
forall l. l -> Exp l -> Type l -> Exp l
ExpTypeSig l
noInfo Exp l
rhExp Type l
typ
    Maybe (Type l)
Nothing -> Exp l -> m (Exp l)
forall (m :: * -> *) a. Monad m => a -> m a
return Exp l
rhExp

  getTypeFor :: [(String, b)] -> Decl a -> Maybe b
getTypeFor [(String, b)]
typeSigs Decl a
decl = case Decl a
decl of
    (PatBind a
_ (PVar a
_ Name a
name) Rhs a
_ Maybe (Binds a)
_) -> String -> [(String, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Name a -> String
forall a. Name a -> String
unname Name a
name) [(String, b)]
typeSigs
    Decl a
_ -> Maybe b
forall a. Maybe a
Nothing

-- | a `op` b => op a b
-- a + b => (+) a b
-- for expressions
desugarInfixOp :: (Data l, Typeable l) => Module l -> Module l
desugarInfixOp :: Module l -> Module l
desugarInfixOp = (Exp l -> Exp l) -> Module l -> Module l
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
(to a -> to a) -> from a -> from a
transformBi ((Exp l -> Exp l) -> Module l -> Module l)
-> (Exp l -> Exp l) -> Module l -> Module l
forall a b. (a -> b) -> a -> b
$ \Exp l
ex -> case Exp l
ex of
  InfixApp l
l Exp l
e1 QOp l
oper Exp l
e2 -> l -> Exp l -> Exp l -> Exp l
forall l. l -> Exp l -> Exp l -> Exp l
App l
l (l -> Exp l -> Exp l -> Exp l
forall l. l -> Exp l -> Exp l -> Exp l
App l
l (QOp l -> Exp l
forall l. QOp l -> Exp l
getOp QOp l
oper) Exp l
e1) Exp l
e2
    where
      getOp :: QOp l -> Exp l
getOp (QVarOp l
l' QName l
o) = l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Var l
l' QName l
o
      getOp (QConOp l
l' QName l
o) = l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Con l
l' QName l
o
  Exp l
_ -> Exp l
ex

-- | a : b => (:) a b for patterns
desugarInfixPat :: (Data l, Typeable l) => Module l -> Module l
desugarInfixPat :: Module l -> Module l
desugarInfixPat = (Pat l -> Pat l) -> Module l -> Module l
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
(to a -> to a) -> from a -> from a
transformBi ((Pat l -> Pat l) -> Module l -> Module l)
-> (Pat l -> Pat l) -> Module l -> Module l
forall a b. (a -> b) -> a -> b
$ \Pat l
pt -> case Pat l
pt of
  PInfixApp l
l Pat l
p1 QName l
iop Pat l
p2 -> l -> QName l -> [Pat l] -> Pat l
forall l. l -> QName l -> [Pat l] -> Pat l
PApp l
l QName l
iop [Pat l
p1, Pat l
p2]
  Pat l
_ -> Pat l
pt

-- | (a) => a for patterns
desugarExpParen :: (Data l, Typeable l) => Module l -> Module l
desugarExpParen :: Module l -> Module l
desugarExpParen = (Exp l -> Exp l) -> Module l -> Module l
forall (from :: * -> *) a (to :: * -> *).
Biplate (from a) (to a) =>
(to a -> to a) -> from a -> from a
transformBi ((Exp l -> Exp l) -> Module l -> Module l)
-> (Exp l -> Exp l) -> Module l -> Module l
forall a b. (a -> b) -> a -> b
$ \Exp l
ex -> case Exp l
ex of
  Paren l
_ Exp l
e -> Exp l
e
  Exp l
_ -> Exp l
ex

transformBi :: U.Biplate (from a) (to a) => (to a -> to a) -> from a -> from a
transformBi :: (to a -> to a) -> from a -> from a
transformBi = (to a -> to a) -> from a -> from a
forall from to. Biplate from to => (to -> to) -> from -> from
U.transformBi

universeBi :: U.Biplate (from a) (to a) => from a -> [to a]
universeBi :: from a -> [to a]
universeBi = from a -> [to a]
forall from to. Biplate from to => from -> [to]
U.universeBi

transformBiM :: (Monad m, U.Biplate (from a) (to a)) => (to a -> m (to a)) -> from a -> m (from a)
transformBiM :: (to a -> m (to a)) -> from a -> m (from a)
transformBiM = (to a -> m (to a)) -> from a -> m (from a)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
U.transformBiM