-- | 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' "$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' prefix :: String
prefix emptyAnnotation :: l
emptyAnnotation md :: 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
$ \ex :: Exp l
ex -> case Exp l
ex of
  LeftSection  l :: l
l e :: Exp l
e q :: 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
$ \tmp :: 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
l q :: QOp l
q e :: 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
$ \tmp :: 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 -> 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
$ \ex :: Exp l
ex -> case Exp l
ex of
  Do _ stmts :: [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 -> 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' inner :: Maybe (Exp l)
inner stmt :: 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 _ exp :: 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 "UnsupportedLet"
      _             -> String -> Maybe (Exp l)
forall a. HasCallStack => String -> a
error "InvalidDoBlock"

    subsequentStmt :: Exp l -> Maybe (Exp l)
subsequentStmt inner' :: Exp l
inner' = case Stmt l
stmt of
      Generator loc :: l
loc pat :: Pat l
pat exp :: 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 s :: l
s exp :: 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 ">>")
                                         Exp l
inner'
      LetStmt _ (BDecls s :: l
s binds :: [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 _ _ -> String -> Maybe (Exp l)
forall a. HasCallStack => String -> a
error "UnsupportedLet"
      RecStmt{} -> String -> Maybe (Exp l)
forall a. HasCallStack => String -> a
error "UnsupportedRecursiveDo"

    desugarGenerator :: l -> Pat l -> Exp l -> Exp l -> Maybe (Exp l)
    desugarGenerator :: l -> Pat l -> Exp l -> Exp l -> Maybe (Exp l)
desugarGenerator s :: l
s pat :: Pat l
pat inner' :: Exp l
inner' exp :: 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 ">>=")
                      (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 md :: 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
$ \ex :: Exp l
ex -> case Exp l
ex of
    Var _ (Special _ 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 _ (Special _ 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
ex
  where
    fromTupleCon :: String -> Exp l -> SpecialCon l -> Exp l
    fromTupleCon :: String -> Exp l -> SpecialCon l -> Exp l
fromTupleCon prefix :: String
prefix e :: Exp l
e s :: 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
l b :: Boxed
b n :: 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)
      _ -> 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
$ \ex :: Exp l
ex -> case Exp l
ex of
  LCase l :: l
l alts :: [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
$ \n :: 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 -> 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
$ \ex :: Exp l
ex -> case Exp l
ex of
  MultiIf l :: l
l alts :: [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
ex

-- | (a,) => \b -> (a,b)
desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l)
desugarTupleSection :: Module l -> Desugar l (Module l)
desugarTupleSection md :: 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
$ \ex :: Exp l
ex -> case Exp l
ex of
    TupleSection l :: l
l _ mes :: [Maybe (Exp l)]
mes -> do
      (names :: [Name l]
names, lst :: [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 -> 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 _ [] _ = ([Name l], [Exp l]) -> Desugar l ([Name l], [Exp l])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    genSlotNames l :: l
l (Nothing : rest :: [Maybe (Exp l)]
rest) ns :: [Name l]
ns = do
      -- it's safe to use head/tail here because ns is an infinite list
      (rn :: [Name l]
rn, re :: [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
l (Just e :: Exp l
e : rest :: [Maybe (Exp l)]
rest) ns :: [Name l]
ns = do
      (rn :: [Name l]
rn, re :: [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
$ \pt :: Pat l
pt -> case Pat l
pt of
  PParen _ p :: Pat l
p -> Pat l
p
  _ -> 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
$ \f :: FieldUpdate l
f -> case FieldUpdate l
f of
  FieldPun l :: l
l n :: 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
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
$ \pf :: PatField l
pf -> case PatField l
pf of
  PFieldPun l :: l
l n :: 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
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
$ \ex :: Exp l
ex -> case Exp l
ex of
    ListComp l :: l
l exp :: Exp l
exp stmts :: [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 -> 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
l e :: 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
l e :: Exp l
e (QualStmt _ (Generator _ p :: Pat l
p e2 :: Exp l
e2) : stmts :: [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
$ \f :: 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 "$Prelude") (l -> String -> Name l
forall l. l -> String -> Name l
Ident l
l "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
l e :: Exp l
e (QualStmt _ (Qualifier _ e2 :: Exp l
e2) : stmts :: [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
l e :: Exp l
e (QualStmt _ (LetStmt _ bs :: Binds l
bs) : stmts :: [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' _ _ (_ : _) =
      String -> Desugar l (Exp l)
forall a. HasCallStack => String -> a
error "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 ex :: Exp l
ex = case Exp l
ex of
      e :: Exp l
e@(EnumFrom       _ e1 :: 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     _ e1 :: Exp l
e1 e2 :: 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   _ e1 :: Exp l
e1 e2 :: 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 _ e1 :: Exp l
e1 e2 :: Exp l
e2 e3 :: 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]
      _ -> () -> 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 :: Exp l
exp es :: [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 e :: Exp l
e = case Exp l
e of
      Con            {} -> Bool
False
      Lit _ Int{}       -> Bool
True
      Lit            {} -> Bool
False
      Tuple          {} -> Bool
False
      List           {} -> Bool
False
      EnumFrom       {} -> Bool
False
      EnumFromTo     {} -> Bool
False
      EnumFromThen   {} -> Bool
False
      EnumFromThenTo {} -> Bool
False
      _                 -> 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 m :: 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 "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 _ _ _ decls :: [ImportDecl l]
decls _) = [ImportDecl l]
decls
    getImportDecls _ = []

    setImportDecls :: [ImportDecl l] -> Module l -> Module l
    setImportDecls :: [ImportDecl l] -> Module l -> Module l
setImportDecls decls :: [ImportDecl l]
decls (Module a :: l
a b :: Maybe (ModuleHead l)
b c :: [ModulePragma l]
c _ d :: [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 _ mod :: 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 decl :: ImportDecl l
decl = case ImportDecl l -> ModuleName l
forall l. ImportDecl l -> ModuleName l
importModule ImportDecl l
decl of
      ModuleName _ name :: String
name -> String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "Prelude"

    addPrelude :: Module l -> Desugar l (Module l)
    addPrelude :: Module l -> Desugar l (Module l)
addPrelude mod :: 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 "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 m :: Module l
m = case Module l
m of
  Module a :: l
a b :: Maybe (ModuleHead l)
b c :: [ModulePragma l]
c d :: [ImportDecl l]
d decls :: [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 -> 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 srcInfo :: l
srcInfo decls :: [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 decls :: [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 ds :: [Decl a]
ds = [ (Name a -> String
forall a. Name a -> String
unname Name a
n, Type a
typ) | TypeSig _ names :: [Name a]
names typ :: Type a
typ <- [Decl a]
ds, Name a
n <- [Name a]
names ]

  go :: [(String, Type l)] -> [Decl l] -> [m (Decl l)]
go typeSigs :: [(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 typeSigs :: [(String, Type l)]
typeSigs decl :: Decl l
decl = case Decl l
decl of
    (PatBind loc :: l
loc pat :: Pat l
pat rhs :: Rhs l
rhs binds :: 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 (srcInfo :: l
srcInfo, rhExp :: 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
        _ -> Decl l -> m (Decl l)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl l
decl
    _ -> 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 :: Rhs a
rhs = case Rhs a
rhs of
    (UnGuardedRhs srcInfo :: a
srcInfo exp :: Exp a
exp) -> (a, Exp a) -> Maybe (a, Exp a)
forall a. a -> Maybe a
Just (a
srcInfo, Exp a
exp)
    _ -> 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 typeSigs :: [(String, Type l)]
typeSigs decl :: Decl a
decl rhExp :: 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 typ :: 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
    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 typeSigs :: [(String, b)]
typeSigs decl :: Decl a
decl = case Decl a
decl of
    (PatBind _ (PVar _ name :: Name a
name) _ _) -> 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
    _ -> 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
$ \ex :: Exp l
ex -> case Exp l
ex of
  InfixApp l :: l
l e1 :: Exp l
e1 oper :: QOp l
oper e2 :: 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
l' o :: 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
l' o :: QName l
o) = l -> QName l -> Exp l
forall l. l -> QName l -> Exp l
Con l
l' QName l
o
  _ -> 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
$ \pt :: Pat l
pt -> case Pat l
pt of
  PInfixApp l :: l
l p1 :: Pat l
p1 iop :: QName l
iop p2 :: 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
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
$ \ex :: Exp l
ex -> case Exp l
ex of
  Paren _ e :: Exp l
e -> Exp l
e
  _ -> 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, Biplate from to) =>
(to -> m to) -> from -> m from
U.transformBiM