{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
module Embedder.HSE.ToAtmo (toAtmo) where

import ReWire.Annotation hiding (ann)
import ReWire.Error
import ReWire.HSE.Exports (Export (..), sDeclHead, getExportFixities, transExport, getTypeExports, resolveExports, getInlines)
import ReWire.HSE.Rename
import Embedder.Atmo.Types ((|->))
import ReWire.SYB (query)

import Control.Monad (foldM, void, when)
import Data.Map.Strict (Map)
import Data.Maybe (mapMaybe, fromMaybe)
import qualified Data.Text as T (Text, pack, replicate, splitOn)
import Language.Haskell.Exts.Pretty (prettyPrint)

import qualified Data.Map.Strict              as Map
import qualified Language.Haskell.Exts.Syntax as S
import qualified Embedder.Builtins              as M
import qualified Embedder.Atmo.Syntax          as M
import qualified Embedder.Atmo.Util            as M
import qualified Embedder.Atmo.Types           as M

import Language.Haskell.Exts.Syntax hiding (Annotation, Name, Kind)
import Embedder.Atmo.Util (isTupleCtor)



-- Name Handling:
      -- Remove s2n after renames [and in mkUid]
      -- Remove Embed
      -- remove n2s
      -- FOR NOW: remove renumber function
      -- remove binds (pretty straightforward, one for each constructor that used it)

type RecEnv = Map T.Text [T.Text]

isPrimMod :: String -> Bool
isPrimMod :: String -> Bool
isPrimMod = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"RWC.Primitives")

{- Name Handling
mkUId :: S.Name a -> Name b
mkUId = \ case
      Ident _ n  -> s2n (pack n)
      Symbol _ n -> s2n (pack n)
-}
mkUId :: S.Name a -> T.Text
mkUId :: forall a. Name a -> Text
mkUId = \ case
      Ident a
_ String
n  -> String -> Text
T.pack String
n
      Symbol a
_ String
n -> String -> Text
T.pack String
n

-- | Translate a Haskell module into the Atmo abstract syntax.
-- Name Handling: Fresh m, rename returns an FQName which is then T.packaged into an Export
toAtmo :: (MonadError AstError m) => Renamer -> Module Annote -> m (M.Module, Exports)
toAtmo :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Module Annote -> m (Module, Exports)
toAtmo Renamer
rn = \ case
      Module Annote
_ (Just (ModuleHead Annote
_ (ModuleName Annote
_ String
mname) Maybe (WarningText Annote)
_ Maybe (ExportSpecList Annote)
exps)) [ModulePragma Annote]
_ [ImportDecl Annote]
_ ([Decl Annote] -> [Decl Annote]
forall a. [a] -> [a]
reverse -> [Decl Annote]
ds) -> do
            tyDefs <- ([DataDefn] -> Decl Annote -> m [DataDefn])
-> [DataDefn] -> [Decl Annote] -> m [DataDefn]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Renamer -> [DataDefn] -> Decl Annote -> m [DataDefn]
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> [DataDefn] -> Decl Annote -> m [DataDefn]
transData Renamer
rn) [] [Decl Annote]
ds
            (recDefs,recEnv) <- transRecs rn ds
            tySyns <- if isPrimMod mname then pure [] -- TODO(chathhorn): ignore type synonyms in the RWC.Primitives module.
                      else foldM (transTyDecl rn) [] ds
            tySigs <- foldM (transTySig rn) [] ds
            fnDefs <- foldM (transDef rn recEnv tySigs inls) [] ds
            exps'  <- maybe (pure $ getGlobExps rn ds) (\ (ExportSpecList Annote
_ [ExportSpec Annote]
exps') -> ([Export] -> ExportSpec Annote -> m [Export])
-> [Export] -> [ExportSpec Annote] -> m [Export]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Renamer
-> [Decl Annote] -> [Export] -> ExportSpec Annote -> m [Export]
forall (m :: * -> *).
MonadError AstError m =>
Renamer
-> [Decl Annote] -> [Export] -> ExportSpec Annote -> m [Export]
transExport Renamer
rn [Decl Annote]
ds) [] [ExportSpec Annote]
exps') exps
            pure (M.Module tyDefs recDefs tySyns fnDefs, resolveExports rn exps')
            where getGlobExps :: Renamer -> [Decl Annote] -> [Export]
                  getGlobExps :: Renamer -> [Decl Annote] -> [Export]
getGlobExps Renamer
rn [Decl Annote]
ds = Renamer -> [Decl Annote] -> [Export]
getTypeExports Renamer
rn [Decl Annote]
ds [Export] -> [Export] -> [Export]
forall a. Semigroup a => a -> a -> a
<> [Decl Annote] -> [Export]
getExportFixities [Decl Annote]
ds [Export] -> [Export] -> [Export]
forall a. Semigroup a => a -> a -> a
<> (Decl Annote -> [Export]) -> [Decl Annote] -> [Export]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Renamer -> Decl Annote -> [Export]
getFunExports Renamer
rn) [Decl Annote]
ds

                  getFunExports :: Renamer -> Decl Annote -> [Export]
                  getFunExports :: Renamer -> Decl Annote -> [Export]
getFunExports Renamer
rn = \ case
                        PatBind Annote
_ (PVar Annote
_ Name Annote
n) Rhs Annote
_ Maybe (Binds Annote)
_ -> [FQName -> Export
Export (FQName -> Export) -> FQName -> Export
forall a b. (a -> b) -> a -> b
$ Namespace -> Renamer -> Name () -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn (Name () -> FQName) -> Name () -> FQName
forall a b. (a -> b) -> a -> b
$ Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
n]
                        FunBind Annote
_ [Match Annote]
ms -> (Match Annote -> Export) -> [Match Annote] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (Renamer -> Match Annote -> Export
getMatchExport Renamer
rn) [Match Annote]
ms
                        Decl Annote
_                        -> []

                  getMatchExport :: Renamer -> Match Annote -> Export
                  getMatchExport :: Renamer -> Match Annote -> Export
getMatchExport Renamer
rn (Match Annote
_ Name Annote
n [Pat Annote]
_ Rhs Annote
_ Maybe (Binds Annote)
_) = FQName -> Export
Export (FQName -> Export) -> FQName -> Export
forall a b. (a -> b) -> a -> b
$ Namespace -> Renamer -> Name () -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn (Name () -> FQName) -> Name () -> FQName
forall a b. (a -> b) -> a -> b
$ Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
n
                  getMatchExport Renamer
_ Match Annote
_ = String -> Export
forall a. HasCallStack => String -> a
error String
"getMatchExport: not a supported Match"

                  inls :: Map (S.Name ()) M.DefnAttr
                  inls :: Map (Name ()) DefnAttr
inls = (Bool -> DefnAttr) -> [Decl Annote] -> Map (Name ()) DefnAttr
forall a. (Bool -> a) -> [Decl Annote] -> Map (Name ()) a
getInlines (\ Bool
b -> if Bool
b then DefnAttr
M.Inline else DefnAttr
M.NoInline) [Decl Annote]
ds
      Module Annote
m                                                                -> Annote -> Text -> m (Module, Exports)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Module Annote -> Annote
forall l. Module l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Module Annote
m) Text
"Unsupported module syntax"

isRecDecl :: QualConDecl l -> Bool
isRecDecl :: forall l. QualConDecl l -> Bool
isRecDecl (QualConDecl l
_ Maybe [TyVarBind l]
_ Maybe (Context l)
_ (RecDecl {})) = Bool
True
isRecDecl QualConDecl l
_ = Bool
False

getRecFields :: [QualConDecl l] -> Maybe [(S.Name (), Type ())]
getRecFields :: forall l. [QualConDecl l] -> Maybe [(Name (), Type ())]
getRecFields [QualConDecl l
_ Maybe [TyVarBind l]
_ Maybe (Context l)
_ (RecDecl l
_ Name l
_ [FieldDecl l]
fields)] =
      [(Name (), Type ())] -> Maybe [(Name (), Type ())]
forall a. a -> Maybe a
Just ([(Name (), Type ())] -> Maybe [(Name (), Type ())])
-> [(Name (), Type ())] -> Maybe [(Name (), Type ())]
forall a b. (a -> b) -> a -> b
$ (FieldDecl l -> [(Name (), Type ())])
-> [FieldDecl l] -> [(Name (), Type ())]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FieldDecl l -> [(Name (), Type ())]
forall l. FieldDecl l -> [(Name (), Type ())]
flattenField [FieldDecl l]
fields
      where
            flattenField :: FieldDecl l -> [(S.Name (), Type ())]
            flattenField :: forall l. FieldDecl l -> [(Name (), Type ())]
flattenField (FieldDecl l
_ [Name l]
ns Type l
ty) = [(Name l -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name l
n, Type l -> Type ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Type l
ty) | Name l
n <- [Name l]
ns]
getRecFields [QualConDecl l]
_ = Maybe [(Name (), Type ())]
forall a. Maybe a
Nothing

getRecConName :: [QualConDecl l] -> Maybe (S.Name l)
getRecConName :: forall l. [QualConDecl l] -> Maybe (Name l)
getRecConName [QualConDecl l
_ Maybe [TyVarBind l]
_ Maybe (Context l)
_ (RecDecl l
_ Name l
con [FieldDecl l]
_)] = Name l -> Maybe (Name l)
forall a. a -> Maybe a
Just Name l
con
getRecConName [QualConDecl l]
_ = Maybe (Name l)
forall a. Maybe a
Nothing

-- Name Handling: Fresh m, rename to T.Text
transRec :: (MonadError AstError m) => Renamer -> [M.RecDefn] -> Decl Annote -> m [M.RecDefn]
transRec :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> [RecDefn] -> Decl Annote -> m [RecDefn]
transRec Renamer
rn [RecDefn]
acc = \ case
      DataDecl Annote
l DataOrNew Annote
_ Maybe (Context Annote)
_ (DeclHead Annote -> (Name (), [TyVarBind ()])
forall a. DeclHead a -> (Name (), [TyVarBind ()])
sDeclHead -> (Name ()
name,[TyVarBind ()]
vars)) [QualConDecl Annote]
cons [Deriving Annote]
_ 
        | Just [(Name (), Type ())]
flatFields <- [QualConDecl Annote] -> Maybe [(Name (), Type ())]
forall l. [QualConDecl l] -> Maybe [(Name (), Type ())]
getRecFields [QualConDecl Annote]
cons
        , (QualConDecl Annote -> Bool) -> [QualConDecl Annote] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all QualConDecl Annote -> Bool
forall l. QualConDecl l -> Bool
isRecDecl [QualConDecl Annote]
cons ->
            do
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([QualConDecl Annote] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [QualConDecl Annote]
cons Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                  Annote -> Text -> m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Multi-constructor record type `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name () -> Text
forall a. Name a -> Text
unqualText Name ()
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"` is not currently supported (try using a single-constructor record instead)"
            let tvs :: [Text]
tvs   = (TyVarBind () -> Text) -> [TyVarBind ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind () -> Text
transTyVar [TyVarBind ()]
vars
                n :: Text
n     = Namespace -> Renamer -> Name () -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Type Renamer
rn Name ()
name
                retTy :: Ty
retTy = Annote -> Ty -> [Ty] -> Ty
M.mkTyApp Annote
l (Annote -> Text -> Ty
M.TyCon Annote
l Text
n) ((Text -> Ty) -> [Text] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Annote -> Text -> Ty
M.TyVar Annote
l) [Text]
tvs)
            tys'  <- ((Name (), Type ()) -> m Ty) -> [(Name (), Type ())] -> m [Ty]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn (Type Annote -> m Ty)
-> ((Name (), Type ()) -> Type Annote)
-> (Name (), Type ())
-> m Ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> Annote) -> Type () -> Type Annote
forall a b. (a -> b) -> Type a -> Type b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Annote -> () -> Annote
forall a b. a -> b -> a
const Annote
l) (Type () -> Type Annote)
-> ((Name (), Type ()) -> Type ())
-> (Name (), Type ())
-> Type Annote
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name (), Type ()) -> Type ()
forall a b. (a, b) -> b
snd) [(Name (), Type ())]
flatFields
            let fieldNames = ((Name (), Type ()) -> Text) -> [(Name (), Type ())] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name () -> Text
forall a. Name a -> Text
unqualText (Name () -> Text)
-> ((Name (), Type ()) -> Name ()) -> (Name (), Type ()) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name (), Type ()) -> Name ()
forall a b. (a, b) -> a
fst) [(Name (), Type ())]
flatFields
                fields' = [Text] -> [Ty] -> [(Text, Ty)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fieldNames [Ty]
tys'
                poly    = Ty -> Poly
M.poly' ([Ty] -> Ty -> Ty
M.sig [Ty]
tys' Ty
retTy)
            pure $ M.RecDefn l n tvs poly fields' : acc
      Decl Annote
_                      -> [RecDefn] -> m [RecDefn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [RecDefn]
acc


buildRecEnv :: [Decl Annote] -> RecEnv
buildRecEnv :: [Decl Annote] -> RecEnv
buildRecEnv = [(Text, [Text])] -> RecEnv
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, [Text])] -> RecEnv)
-> ([Decl Annote] -> [(Text, [Text])]) -> [Decl Annote] -> RecEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decl Annote -> Maybe (Text, [Text]))
-> [Decl Annote] -> [(Text, [Text])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Decl Annote -> Maybe (Text, [Text])
forall {l}. Decl l -> Maybe (Text, [Text])
extract
  where
    extract :: Decl l -> Maybe (Text, [Text])
extract (DataDecl l
_ DataOrNew l
_ Maybe (Context l)
_ (DeclHead l -> (Name (), [TyVarBind ()])
forall a. DeclHead a -> (Name (), [TyVarBind ()])
sDeclHead -> (Name ()
_, [TyVarBind ()]
_)) [QualConDecl l]
cons [Deriving l]
_)
      | Just [(Name (), Type ())]
flatFields <- [QualConDecl l] -> Maybe [(Name (), Type ())]
forall l. [QualConDecl l] -> Maybe [(Name (), Type ())]
getRecFields [QualConDecl l]
cons
      , Just Name l
con <- [QualConDecl l] -> Maybe (Name l)
forall l. [QualConDecl l] -> Maybe (Name l)
getRecConName [QualConDecl l]
cons
      , (QualConDecl l -> Bool) -> [QualConDecl l] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all QualConDecl l -> Bool
forall l. QualConDecl l -> Bool
isRecDecl [QualConDecl l]
cons
      , [QualConDecl l] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [QualConDecl l]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 =
          (Text, [Text]) -> Maybe (Text, [Text])
forall a. a -> Maybe a
Just (Name l -> Text
forall a. Name a -> Text
unqualText Name l
con, ((Name (), Type ()) -> Text) -> [(Name (), Type ())] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name () -> Text
forall a. Name a -> Text
unqualText (Name () -> Text)
-> ((Name (), Type ()) -> Name ()) -> (Name (), Type ()) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name (), Type ()) -> Name ()
forall a b. (a, b) -> a
fst) [(Name (), Type ())]
flatFields)
    extract Decl l
_ = Maybe (Text, [Text])
forall a. Maybe a
Nothing

transRecs :: (MonadError AstError m) => Renamer -> [Decl Annote] -> m ([M.RecDefn], RecEnv)
transRecs :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> [Decl Annote] -> m ([RecDefn], RecEnv)
transRecs Renamer
rn [Decl Annote]
decls = do
  recDefs <- ([RecDefn] -> Decl Annote -> m [RecDefn])
-> [RecDefn] -> [Decl Annote] -> m [RecDefn]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Renamer -> [RecDefn] -> Decl Annote -> m [RecDefn]
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> [RecDefn] -> Decl Annote -> m [RecDefn]
transRec Renamer
rn) [] [Decl Annote]
decls
  let recEnv = [Decl Annote] -> RecEnv
buildRecEnv [Decl Annote]
decls
  pure (recDefs, recEnv)

transData :: (MonadError AstError m) => Renamer -> [M.DataDefn] -> Decl Annote -> m [M.DataDefn]
transData :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> [DataDefn] -> Decl Annote -> m [DataDefn]
transData Renamer
rn [DataDefn]
acc = \ case
      DataDecl Annote
l DataOrNew Annote
_ Maybe (Context Annote)
_ (DeclHead Annote -> (Name (), [TyVarBind ()])
forall a. DeclHead a -> (Name (), [TyVarBind ()])
sDeclHead -> (Name ()
name,[TyVarBind ()]
vars)) [QualConDecl Annote]
cons [Deriving Annote]
_ ->
            if (QualConDecl Annote -> Bool) -> [QualConDecl Annote] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any QualConDecl Annote -> Bool
forall l. QualConDecl l -> Bool
isRecDecl [QualConDecl Annote]
cons
            then [DataDefn] -> m [DataDefn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DataDefn]
acc
            else
                  do
                  let n :: Text
n    = Namespace -> Renamer -> Name () -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Type Renamer
rn Name ()
name
                      tvs' :: [Text]
tvs' = (TyVarBind () -> Text) -> [TyVarBind ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind () -> Text
transTyVar [TyVarBind ()]
vars
                  cs'  <- (QualConDecl Annote -> m DataCon)
-> [QualConDecl Annote] -> m [DataCon]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> [Text] -> Text -> QualConDecl Annote -> m DataCon
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> [Text] -> Text -> QualConDecl Annote -> m DataCon
transCon Renamer
rn [Text]
tvs' Text
n) [QualConDecl Annote]
cons
                  pure $ M.DataDefn l n tvs' cs' : acc
      Decl Annote
_                                       -> [DataDefn] -> m [DataDefn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DataDefn]
acc

-- Name Handling: Fresh m, rename returns T.Text
transTyDecl :: (MonadError AstError m) => Renamer -> [M.TypeSynonym] -> Decl Annote -> m [M.TypeSynonym]
transTyDecl :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> [TypeSynonym] -> Decl Annote -> m [TypeSynonym]
transTyDecl Renamer
rn [TypeSynonym]
syns = \ case
      TypeDecl Annote
l (DeclHead Annote -> (Name (), [TyVarBind ()])
forall a. DeclHead a -> (Name (), [TyVarBind ()])
sDeclHead -> (Name (), [TyVarBind ()])
hd) Type Annote
t -> do
            let n :: Text
n   = Namespace -> Renamer -> Name () -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Type Renamer
rn (Name () -> Text) -> Name () -> Text
forall a b. (a -> b) -> a -> b
$ (Name (), [TyVarBind ()]) -> Name ()
forall a b. (a, b) -> a
fst (Name (), [TyVarBind ()])
hd
                lhs :: [Text]
lhs = (TyVarBind () -> Text) -> [TyVarBind ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind () -> Text
transTyVar ([TyVarBind ()] -> [Text]) -> [TyVarBind ()] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Name (), [TyVarBind ()]) -> [TyVarBind ()]
forall a b. (a, b) -> b
snd (Name (), [TyVarBind ()])
hd
            t'  <- Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn Type Annote
t
            pure $ M.TypeSynonym l n (lhs |-> t') : syns
      Decl Annote
_                              -> [TypeSynonym] -> m [TypeSynonym]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TypeSynonym]
syns
      -- lhs used to be tvs'
-- Name Handling: renumber selects 'n : Name Ty' from 'rhs : [Name Ty]' by
--   taking one one with a matching n2s (I think that's just the fv name part)
--   and if there isn't one, then use 'n' instead
-- this is used to fix an error in transTy, it seems...
--     lhs = transTyVar (fvs from TypeDecl header)
--     rhs = fv of (transTy of (t from TypeDecl))
--     the tvs' that we keep for our TypeSynonym are lhs, renumbered using rhs 


-- Name Handling: Fresh m
transTySig :: (MonadError AstError m) => Renamer -> [(S.Name (), M.Ty)] -> Decl Annote -> m [(S.Name (), M.Ty)]
transTySig :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> [(Name (), Ty)] -> Decl Annote -> m [(Name (), Ty)]
transTySig Renamer
rn [(Name (), Ty)]
sigs = \ case
      TypeSig Annote
_ [Name Annote]
names Type Annote
t -> do
            t' <- Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn Type Annote
t
            pure $ map ((, t') . void) names <> sigs
      Decl Annote
_                 -> [(Name (), Ty)] -> m [(Name (), Ty)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Name (), Ty)]
sigs

-- TODO(mheim): need the simple allUnguarded Match case, and also the non-var PatBind case
-- TODO(chathhorn): should be a map, not a fold
-- Name Handling: Fresh m, rename returns T.Text
transDef :: (MonadError AstError m) => Renamer -> RecEnv -> [(S.Name (), M.Ty)] -> Map (S.Name ()) M.DefnAttr -> [M.Defn] -> Decl Annote -> m [M.Defn]
transDef :: forall (m :: * -> *).
MonadError AstError m =>
Renamer
-> RecEnv
-> [(Name (), Ty)]
-> Map (Name ()) DefnAttr
-> [Defn]
-> Decl Annote
-> m [Defn]
transDef Renamer
rn RecEnv
recEnv [(Name (), Ty)]
tys Map (Name ()) DefnAttr
inls [Defn]
defs = \ case
      PatBind Annote
l (PVar Annote
_ (Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void -> Name ()
x)) (UnGuardedRhs Annote
_ Exp Annote
e) Maybe (Binds Annote)
Nothing -> do
            let x' :: Text
x' = Namespace -> Renamer -> Name () -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn Name ()
x
                t :: Ty
t  = Ty -> Maybe Ty -> Ty
forall a. a -> Maybe a -> a
fromMaybe (Annote -> Text -> Ty
M.TyVar Annote
l Text
"a") (Maybe Ty -> Ty) -> Maybe Ty -> Ty
forall a b. (a -> b) -> a -> b
$ Name () -> [(Name (), Ty)] -> Maybe Ty
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name ()
x [(Name (), Ty)]
tys
            -- Elide definition of primitives. Allows providing alternate defs for GHC compat.
            e' <- if Text -> Bool
forall a. Show a => a -> Bool
M.isPrim Text
x' then Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Ty -> Text -> Exp
M.mkError (Exp Annote -> Annote
forall l. Exp l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Exp Annote
e) (Ty -> Maybe Ty
forall a. a -> Maybe a
Just Ty
t) (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Text
"Prim: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x'
                  else Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv Exp Annote
e
            pure $ M.Defn l x' (M.poly' t) (Map.lookup x inls) [M.FunBinding l [] e'] : defs
      FunBind Annote
l ms :: [Match Annote]
ms@(Match Annote
_l' (Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void -> Name ()
name) [Pat Annote]
_ps Rhs Annote
_rhs Maybe (Binds Annote)
_binds : [Match Annote]
_) -> do
            let name' :: Text
name' = Namespace -> Renamer -> Name () -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn Name ()
name
                t :: Ty
t  = Ty -> Maybe Ty -> Ty
forall a. a -> Maybe a -> a
fromMaybe (Annote -> Text -> Ty
M.TyVar Annote
l Text
"a") (Maybe Ty -> Ty) -> Maybe Ty -> Ty
forall a b. (a -> b) -> a -> b
$ Name () -> [(Name (), Ty)] -> Maybe Ty
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name ()
name [(Name (), Ty)]
tys
            ms' <- (Match Annote -> m FunBinding) -> [Match Annote] -> m [FunBinding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> RecEnv -> Match Annote -> m FunBinding
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Match Annote -> m FunBinding
transFunMatch Renamer
rn RecEnv
recEnv) [Match Annote]
ms
            pure $ M.Defn l name' (M.poly' t) (Map.lookup name inls) ms' : defs
      DataDecl       {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      InlineSig      {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      TypeSig        {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      InfixDecl      {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      TypeDecl       {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      AnnPragma      {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      MinimalPragma  {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      CompletePragma {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      RulePragmaDecl {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      DeprPragmaDecl {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      WarnPragmaDecl {}                                         -> [Defn] -> m [Defn]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Defn]
defs -- TODO(chathhorn): elide
      Decl Annote
d                                                         -> Annote -> Text -> m [Defn]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Decl Annote -> Annote
forall l. Decl l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Decl Annote
d) (Text -> m [Defn]) -> Text -> m [Defn]
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported definition syntax: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Decl () -> String
forall a. Show a => a -> String
show (Decl () -> String) -> Decl () -> String
forall a b. (a -> b) -> a -> b
$ Decl Annote -> Decl ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Decl Annote
d)


-- We no longer desugar simple function bindings during HSE.Desugar
-- That is, we assume that we can have function bindings with zero guards and zero local bindings
transFunMatch :: (MonadError AstError m) => Renamer -> RecEnv -> Match Annote -> m M.FunBinding
transFunMatch :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Match Annote -> m FunBinding
transFunMatch Renamer
rn RecEnv
recEnv (Match Annote
_l Name Annote
name [Pat Annote]
ps (UnGuardedRhs Annote
l' Exp Annote
e) Maybe (Binds Annote)
Nothing) = do
      let name' :: Text
name' = Namespace -> Renamer -> Name Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn Name Annote
name
      e' <- if Text -> Bool
forall a. Show a => a -> Bool
M.isPrim Text
name' then Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Ty -> Text -> Exp
M.mkError (Exp Annote -> Annote
forall l. Exp l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Exp Annote
e) Maybe Ty
forall a. Maybe a
Nothing (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Text
"Prim: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name'
            else Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv Exp Annote
e
      ps' <- mapM (transPat rn) ps
      pure $ M.FunBinding l' ps' e'
transFunMatch Renamer
_ RecEnv
_ Match Annote
m = Annote -> Text -> m FunBinding
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Match Annote -> Annote
forall l. Match l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Match Annote
m) Text
"transFunMatch: unsupported Match type"

-- Name Handling: used to return Name a b/c of mkUId
transTyVar :: S.TyVarBind () -> T.Text
transTyVar :: TyVarBind () -> Text
transTyVar = \ case
      S.UnkindedVar ()
_ Name ()
x -> Name () -> Text
forall a. Name a -> Text
mkUId Name ()
x
      S.KindedVar ()
_ Name ()
x Type ()
_ -> Name () -> Text
forall a. Name a -> Text
mkUId Name ()
x

-- Name Handling: Fresh m, rename returns T.Text
   -- previously: Renamer -> [Name M.Ty] -> Name M.TyConId ->
transCon :: (MonadError AstError m) => Renamer -> [T.Text] -> T.Text -> QualConDecl Annote -> m M.DataCon
transCon :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> [Text] -> Text -> QualConDecl Annote -> m DataCon
transCon Renamer
rn [Text]
tvs Text
tc = \ case
      QualConDecl Annote
l Maybe [TyVarBind Annote]
Nothing Maybe (Context Annote)
_ (ConDecl Annote
_ Name Annote
x [Type Annote]
tys) -> do
            let tvs' :: [Ty]
tvs' = (Text -> Ty) -> [Text] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Annote -> Text -> Ty
M.TyVar Annote
l) [Text]
tvs
            tys' <- (Type Annote -> m Ty) -> [Type Annote] -> m [Ty]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn) [Type Annote]
tys
            let t = [Ty] -> Ty -> Ty
M.sig [Ty]
tys' (Annote -> Ty -> [Ty] -> Ty
M.TyApp Annote
l (Annote -> Text -> Ty
M.TyCon Annote
l Text
tc) [Ty]
tvs')
            pure $ M.DataCon l (rename Value rn x) (tvs |-> t)
      QualConDecl Annote
d                                         -> Annote -> Text -> m DataCon
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (QualConDecl Annote -> Annote
forall l. QualConDecl l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QualConDecl Annote
d) Text
"Unsupported Ctor syntax"

{- Kind Handling:
takes ks : [M.Kind] after Renamer
uses them in creating TyVars (let tvs' = zipWith (M.TyVar l) ks tvs)

-}

flattenTyApp :: Type Annote -> [Type Annote]
flattenTyApp :: Type Annote -> [Type Annote]
flattenTyApp = \ case
      TyApp Annote
_l Type Annote
a Type Annote
b -> Type Annote -> [Type Annote]
flattenTyApp Type Annote
a [Type Annote] -> [Type Annote] -> [Type Annote]
forall a. Semigroup a => a -> a -> a
<> [Type Annote
b]
      Type Annote
t           -> [Type Annote
t]

-- Name Handling: Fresh m, rename returns T.Text
transTy :: (MonadError AstError m) => Renamer -> Type Annote -> m M.Ty
transTy :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn = \ case
      TyForall Annote
_ Maybe [TyVarBind Annote]
_ Maybe (Context Annote)
_ Type Annote
t -> Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn Type Annote
t
      t :: Type Annote
t@(TyApp Annote
l Type Annote
_ Type Annote
_)  -> case Type Annote -> [Type Annote]
flattenTyApp Type Annote
t of
            [] -> String -> m Ty
forall a. HasCallStack => String -> a
error String
"Impossible flattenTyApp return"
            [Type Annote
_t] -> String -> m Ty
forall a. HasCallStack => String -> a
error String
"transTy: impossible given value of t"
            (Type Annote
t1 : [Type Annote]
ts) -> Annote -> Ty -> [Ty] -> Ty
M.TyApp Annote
l (Ty -> [Ty] -> Ty) -> m Ty -> m ([Ty] -> Ty)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn Type Annote
t1 m ([Ty] -> Ty) -> m [Ty] -> m Ty
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type Annote -> m Ty) -> [Type Annote] -> m [Ty]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn) [Type Annote]
ts
      TyCon Annote
l QName Annote
x | Just TyBuiltin
b <- Name Annote -> Maybe TyBuiltin
tybuiltin (Namespace -> Renamer -> QName Annote -> Name Annote
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Type Renamer
rn QName Annote
x)
                       -> Ty -> m Ty
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty -> m Ty) -> Ty -> m Ty
forall a b. (a -> b) -> a -> b
$ Annote -> TyBuiltin -> Ty
M.TyBuiltin Annote
l TyBuiltin
b
      TyCon Annote
l QName Annote
x -> Ty -> m Ty
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty -> m Ty) -> Ty -> m Ty
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> Ty
M.TyCon Annote
l (Namespace -> Renamer -> QName Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Type Renamer
rn QName Annote
x)
      TyVar Annote
l Name Annote
x        -> (Ty -> m Ty
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annote -> Text -> Ty
M.TyVar Annote
l (Name () -> Text
forall a. Name a -> Text
mkUId (Name () -> Text) -> Name () -> Text
forall a b. (a -> b) -> a -> b
$ Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
x)))
      TyList Annote
l Type Annote
a       -> Annote -> Ty -> Ty
M.listTy Annote
l (Ty -> Ty) -> m Ty -> m Ty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn Type Annote
a
      TyTuple Annote
l Boxed
_ [Type Annote]
ts     -> do
                        ts' <- (Type Annote -> m Ty) -> [Type Annote] -> m [Ty]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn) [Type Annote]
ts
                        pure $ M.TyTuple l ts'
      TyPromoted Annote
l (PromotedInteger Annote
_ Integer
n String
_)
            | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0   -> Ty -> m Ty
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ty -> m Ty) -> Ty -> m Ty
forall a b. (a -> b) -> a -> b
$ Annote -> Natural -> Ty
M.TyNat Annote
l (Natural -> Ty) -> Natural -> Ty
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a. Num a => Integer -> a
fromInteger Integer
n
      TyInfix Annote
l Type Annote
a MaybePromotedName Annote
x Type Annote
b -> Annote -> Ty -> [Ty] -> Ty
M.TyApp Annote
l (Annote -> Text -> Ty
M.TyCon Annote
l (Namespace -> Renamer -> QName Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Type Renamer
rn QName Annote
x')) ([Ty] -> Ty) -> m [Ty] -> m Ty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m Ty] -> m [Ty]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn Type Annote
a , Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn Type Annote
b]
            where x' :: QName Annote
x' | PromotedName   Annote
_ QName Annote
qn <- MaybePromotedName Annote
x = QName Annote
qn
                     | UnpromotedName Annote
_ QName Annote
qn <- MaybePromotedName Annote
x = QName Annote
qn
      Type Annote
t                -> Annote -> Text -> m Ty
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Type Annote -> Annote
forall l. Type l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Type Annote
t) (Text -> m Ty) -> Text -> m Ty
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported type syntax: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Type Annote -> String
forall a. Show a => a -> String
show Type Annote
t)
      where 
            tybuiltin :: S.Name Annote -> Maybe M.TyBuiltin
            tybuiltin :: Name Annote -> Maybe TyBuiltin
tybuiltin = Text -> Maybe TyBuiltin
M.tybuiltin (Text -> Maybe TyBuiltin)
-> (Name Annote -> Text) -> Name Annote -> Maybe TyBuiltin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name Annote -> String) -> Name Annote -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name () -> String
forall a. Pretty a => a -> String
prettyPrint (Name () -> String)
-> (Name Annote -> Name ()) -> Name Annote -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FQName -> Name ()
name (FQName -> Name ())
-> (Name Annote -> FQName) -> Name Annote -> Name ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> Renamer -> Name Annote -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn

-- Name Handling: Fresh m, rename returns T.Text, except builtin function where 'name' is called on the return value
transExp :: (MonadError AstError m) => Renamer -> RecEnv -> Exp Annote -> m M.Exp
transExp :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv = \ case
      App Annote
l Exp Annote
e1 Exp Annote
e2            -> do
            let es :: [Exp Annote]
es = Exp Annote -> [Exp Annote]
flattenApp (Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l Exp Annote
e1 Exp Annote
e2)
            es' <- (Exp Annote -> m Exp) -> [Exp Annote] -> m [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv) [Exp Annote]
es
            case es' of 
                  (M.Con Annote
_ Maybe Poly
_ Maybe Ty
_ Text
cname : [Exp]
args)
                    | Just [Text]
fieldNames <- Text -> RecEnv -> Maybe [Text]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Text
stripModPrefix Text
cname) RecEnv
recEnv
                    , [Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
fieldNames ->
                        Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Maybe Ty -> [(Text, Exp)] -> Exp
M.RecVal Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing ([Text] -> [Exp] -> [(Text, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fieldNames [Exp]
args)
                  (Exp
e' : [Exp]
es'') -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Exp -> [Exp] -> Exp
M.mkApp Annote
l Exp
e' [Exp]
es''
                  [Exp]
_ -> Annote -> Text -> m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"transExp: Application with no arguments"
      Lambda Annote
l [PVar Annote
a Name Annote
x] Exp Annote
e  -> do
            (vs',e') <- Renamer -> Exp Annote -> m ([Text], Exp)
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Exp Annote -> m ([Text], Exp)
flattenLam Renamer
rn (Annote -> [Pat Annote] -> Exp Annote -> Exp Annote
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda Annote
l [Annote -> Name Annote -> Pat Annote
forall l. l -> Name l -> Pat l
PVar Annote
a Name Annote
x] Exp Annote
e)
            pure $ M.Lam l Nothing Nothing vs' e'  -- vs' =? map (mkUId . void) vs
      Var Annote
l QName Annote
x | Just RWUserOp
b <- QName Annote -> Maybe RWUserOp
rwUserDef QName Annote
x
                             -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Maybe Ty -> RWUserOp -> Exp
M.RWUser Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing RWUserOp
b
      Var Annote
l QName Annote
x | Just Builtin
b <- QName Annote -> Maybe Builtin
builtins QName Annote
x
                             -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Maybe Ty -> RWUserOp -> Exp
M.RWUser Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing (Builtin -> RWUserOp
M.RWBuiltin Builtin
b)
      Var Annote
l QName Annote
x                -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Maybe Ty -> Text -> Exp
M.Var Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Namespace -> Renamer -> QName Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
x
      Con Annote
l QName Annote
x                -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Maybe Ty -> Text -> Exp
M.Con Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Namespace -> Renamer -> QName Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
x
      Case Annote
l Exp Annote
e [Alt Annote]
alts -> do
            e'  <- Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv Exp Annote
e
            alts' <- mapM transAlt alts
            pure $ M.Case l Nothing Nothing e' alts'
      Tuple Annote
l Boxed
_ [Exp Annote]
es           -> do
            es' <- (Exp Annote -> m Exp) -> [Exp Annote] -> m [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv) [Exp Annote]
es
            pure $ M.Tuple l Nothing Nothing es'
      Lit Annote
l (Int Annote
_ Integer
n String
_)      -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Integer -> Exp
M.LitInt Annote
l Maybe Poly
forall a. Maybe a
Nothing Integer
n
      Lit Annote
l (String Annote
_ String
s String
_)   -> Exp -> m Exp
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Text -> Exp
M.LitStr Annote
l Maybe Poly
forall a. Maybe a
Nothing (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
      List Annote
l [Exp Annote]
es              -> Annote -> Maybe Poly -> Maybe Ty -> [Exp] -> Exp
M.LitList Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing ([Exp] -> Exp) -> m [Exp] -> m Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp Annote -> m Exp) -> [Exp Annote] -> m [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv) [Exp Annote]
es
      RecConstr Annote
l QName Annote
_ [FieldUpdate Annote]
fields -> do 
            fields' <- (FieldUpdate Annote -> m (Text, Exp))
-> [FieldUpdate Annote] -> m [(Text, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> RecEnv -> FieldUpdate Annote -> m (Text, Exp)
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> FieldUpdate Annote -> m (Text, Exp)
transFieldUpdate Renamer
rn RecEnv
recEnv) [FieldUpdate Annote]
fields
            pure $ M.RecVal l Nothing Nothing fields'
      RecUpdate Annote
l Exp Annote
e [FieldUpdate Annote]
fieldUpdates -> do
            e' <- Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv Exp Annote
e
            fieldUpdates' <- mapM (transFieldUpdate rn recEnv) fieldUpdates
            pure $ M.RecUpd l Nothing Nothing e' fieldUpdates'
      ExpTypeSig Annote
_ Exp Annote
e Type Annote
t       -> Maybe Poly -> Exp -> Exp
forall a. TypeAnnotated a => Maybe Poly -> a -> a
M.setTyAnn (Maybe Poly -> Exp -> Exp)
-> (Ty -> Maybe Poly) -> Ty -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Poly -> Maybe Poly
forall a. a -> Maybe a
Just (Poly -> Maybe Poly) -> (Ty -> Poly) -> Ty -> Maybe Poly
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty -> Poly
M.poly' (Ty -> Exp -> Exp) -> m Ty -> m (Exp -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn Type Annote
t m (Exp -> Exp) -> m Exp -> m Exp
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv Exp Annote
e
      Exp Annote
e                      -> Annote -> Text -> m Exp
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Exp Annote -> Annote
forall l. Exp l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Exp Annote
e) (Text -> m Exp) -> Text -> m Exp
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported expression syntax: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Exp () -> String
forall a. Show a => a -> String
show (Exp () -> String) -> Exp () -> String
forall a b. (a -> b) -> a -> b
$ Exp Annote -> Exp ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Exp Annote
e)
      where getVars :: Pat Annote -> [S.Name ()]
            getVars :: Pat Annote -> [Name ()]
getVars Pat Annote
p = [Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
x | PVar (Annote
_::Annote) Name Annote
x <- Pat Annote -> [Pat Annote]
forall a b. (Data a, Data b) => a -> [b]
query Pat Annote
p]

            transAlt :: (MonadError AstError m) => Alt Annote -> m M.PatBind
            transAlt :: forall (m :: * -> *).
MonadError AstError m =>
Alt Annote -> m PatBind
transAlt (Alt Annote
_ Pat Annote
p (UnGuardedRhs Annote
_ Exp Annote
e1) Maybe (Binds Annote)
_) = do
                  p'  <- Renamer -> Pat Annote -> m Pat
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Pat Annote -> m Pat
transPat Renamer
rn Pat Annote
p
                  e1' <- transExp (exclude Value (getVars p) rn) recEnv e1
                  pure $ M.PatBind p' e1'
            transAlt Alt Annote
a = Annote -> Text -> m PatBind
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Alt Annote -> Annote
forall l. Alt l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Alt Annote
a) (Text -> m PatBind) -> Text -> m PatBind
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported Alt syntax: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Alt () -> String
forall a. Show a => a -> String
show (Alt () -> String) -> Alt () -> String
forall a b. (a -> b) -> a -> b
$ Alt Annote -> Alt ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Alt Annote
a)

            rwUserDef :: QName Annote -> Maybe M.RWUserOp
            rwUserDef :: QName Annote -> Maybe RWUserOp
rwUserDef = Text -> Maybe RWUserOp
M.qn2rwu (Text -> Maybe RWUserOp)
-> (QName Annote -> Text) -> QName Annote -> Maybe RWUserOp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> Renamer -> QName Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn
                  -- M.s2rwu . T.pack . prettyPrint . name . rename Value rn

            builtins :: QName Annote -> Maybe M.Builtin
            builtins :: QName Annote -> Maybe Builtin
builtins =  Text -> Maybe Builtin
M.builtin (Text -> Maybe Builtin)
-> (QName Annote -> Text) -> QName Annote -> Maybe Builtin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (QName Annote -> String) -> QName Annote -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name () -> String
forall a. Pretty a => a -> String
prettyPrint (Name () -> String)
-> (QName Annote -> Name ()) -> QName Annote -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FQName -> Name ()
name (FQName -> Name ())
-> (QName Annote -> FQName) -> QName Annote -> Name ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> Renamer -> QName Annote -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn
            
            flattenApp :: Exp Annote -> [Exp Annote]
            flattenApp :: Exp Annote -> [Exp Annote]
flattenApp = \ case
                  App Annote
_l Exp Annote
e Exp Annote
e' -> Exp Annote -> [Exp Annote]
flattenApp Exp Annote
e [Exp Annote] -> [Exp Annote] -> [Exp Annote]
forall a. Semigroup a => a -> a -> a
<> [Exp Annote
e']
                  Exp Annote
e          -> [Exp Annote
e]
            flattenLam :: (MonadError AstError m) => Renamer -> Exp Annote 
                       -> m ([T.Text],M.Exp)
            flattenLam :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Exp Annote -> m ([Text], Exp)
flattenLam Renamer
rn = \ case
                  Lambda Annote
_ [PVar Annote
_ Name Annote
x] Exp Annote
e  -> do
                        (vs',e') <- Renamer -> Exp Annote -> m ([Text], Exp)
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Exp Annote -> m ([Text], Exp)
flattenLam Renamer
rn Exp Annote
e -- rn =? exclude Value [void x] rn
                        let x' = Namespace -> Renamer -> Name Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn Name Annote
x
                        return (x' : vs', e')
                  Exp Annote
e -> do
                        e' <- Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv Exp Annote
e
                        return ([],e')


-- Name Handling: Fresh m, rename returns T.Text
transPat :: (MonadError AstError m) => Renamer -> Pat Annote -> m M.Pat
transPat :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Pat Annote -> m Pat
transPat Renamer
rn = \ case
      PApp Annote
l QName Annote
x [Pat Annote]
ps | Text -> Bool
isTupleCtor (Namespace -> Renamer -> QName Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
x) -> Annote -> Maybe Poly -> Maybe Ty -> [Pat] -> Pat
M.PatTuple Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing ([Pat] -> Pat) -> m [Pat] -> m Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat Annote -> m Pat) -> [Pat Annote] -> m [Pat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> Pat Annote -> m Pat
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Pat Annote -> m Pat
transPat Renamer
rn) [Pat Annote]
ps
      PApp Annote
l QName Annote
x [Pat Annote]
ps      -> Annote -> Maybe Poly -> Maybe Ty -> Text -> [Pat] -> Pat
M.PatCon Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing (Namespace -> Renamer -> QName Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
x) ([Pat] -> Pat) -> m [Pat] -> m Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat Annote -> m Pat) -> [Pat Annote] -> m [Pat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> Pat Annote -> m Pat
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Pat Annote -> m Pat
transPat Renamer
rn) [Pat Annote]
ps
      PVar Annote
l Name Annote
x         -> Pat -> m Pat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> m Pat) -> Pat -> m Pat
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Maybe Ty -> Text -> Pat
M.PatVar Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing (Name () -> Text
forall a. Name a -> Text
mkUId (Name () -> Text) -> Name () -> Text
forall a b. (a -> b) -> a -> b
$ Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
x)
      PWildCard Annote
l      -> Pat -> m Pat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> m Pat) -> Pat -> m Pat
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Maybe Ty -> Pat
M.PatWildCard Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing
      PatTypeSig Annote
_ Pat Annote
p Type Annote
t -> Maybe Poly -> Pat -> Pat
forall a. TypeAnnotated a => Maybe Poly -> a -> a
M.setTyAnn (Maybe Poly -> Pat -> Pat)
-> (Ty -> Maybe Poly) -> Ty -> Pat -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Poly -> Maybe Poly
forall a. a -> Maybe a
Just (Poly -> Maybe Poly) -> (Ty -> Poly) -> Ty -> Maybe Poly
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ty -> Poly
M.poly' (Ty -> Pat -> Pat) -> m Ty -> m (Pat -> Pat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Renamer -> Type Annote -> m Ty
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Type Annote -> m Ty
transTy Renamer
rn Type Annote
t m (Pat -> Pat) -> m Pat -> m Pat
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Renamer -> Pat Annote -> m Pat
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Pat Annote -> m Pat
transPat Renamer
rn Pat Annote
p
      PTuple Annote
l Boxed
_b [Pat Annote]
ps   -> Annote -> Maybe Poly -> Maybe Ty -> [Pat] -> Pat
M.PatTuple Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing ([Pat] -> Pat) -> m [Pat] -> m Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat Annote -> m Pat) -> [Pat Annote] -> m [Pat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> Pat Annote -> m Pat
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Pat Annote -> m Pat
transPat Renamer
rn) [Pat Annote]
ps
      PAsPat Annote
l Name Annote
n Pat Annote
p     -> case Pat Annote
p of
            PRec Annote
l QName Annote
_ [] -> Pat -> m Pat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> m Pat) -> Pat -> m Pat
forall a b. (a -> b) -> a -> b
$ Annote -> Maybe Poly -> Maybe Ty -> Text -> Pat
M.PatVar Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing (Name () -> Text
forall a. Name a -> Text
mkUId (Name () -> Text) -> Name () -> Text
forall a b. (a -> b) -> a -> b
$ Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
n)
            Pat Annote
_ -> Annote -> Maybe Poly -> Maybe Ty -> Text -> Pat -> Pat
M.PatAs Annote
l Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing (Name () -> Text
forall a. Name a -> Text
mkUId (Name () -> Text) -> Name () -> Text
forall a b. (a -> b) -> a -> b
$ Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
n) (Pat -> Pat) -> m Pat -> m Pat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Renamer -> Pat Annote -> m Pat
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Pat Annote -> m Pat
transPat Renamer
rn Pat Annote
p
      PRec Annote
l QName Annote
_ [PatField Annote]
fields -> do
            case [PatField Annote]
fields of
                  [] -> Annote -> Text -> m Pat
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Empty record pattern without as-pattern is unsupported or unnecessary"
                  [PatField Annote]
_ -> do
                        fields' <- (PatField Annote -> m (Text, Pat))
-> [PatField Annote] -> m [(Text, Pat)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Renamer -> PatField Annote -> m (Text, Pat)
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> PatField Annote -> m (Text, Pat)
transPatField Renamer
rn) [PatField Annote]
fields
                        pure $ M.PatRec l Nothing Nothing fields' 
      Pat Annote
p                -> Annote -> Text -> m Pat
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Pat Annote -> Annote
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat Annote
p) (Text -> m Pat) -> Text -> m Pat
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported syntax in a pattern: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Pat () -> String
forall a. Show a => a -> String
show (Pat () -> String) -> Pat () -> String
forall a b. (a -> b) -> a -> b
$ Pat Annote -> Pat ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Pat Annote
p)

transPatField :: MonadError AstError m => Renamer -> PatField Annote -> m (T.Text, M.Pat)
transPatField :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> PatField Annote -> m (Text, Pat)
transPatField Renamer
rn = \case
  PFieldPat Annote
_ QName Annote
qname Pat Annote
p -> do
    p' <- Renamer -> Pat Annote -> m Pat
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Pat Annote -> m Pat
transPat Renamer
rn Pat Annote
p
    pure (unqualQName qname, p')

  PFieldPun Annote
_ QName Annote
qname -> do
    let n :: Name Annote
n = QName Annote -> Name Annote
forall l. QName l -> Name l
nameFromQName QName Annote
qname
    (Text, Pat) -> m (Text, Pat)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QName Annote -> Text
forall l. QName l -> Text
unqualQName QName Annote
qname, Annote -> Maybe Poly -> Maybe Ty -> Text -> Pat
M.PatVar (QName Annote -> Annote
forall l. QName l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QName Annote
qname) Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing (Name () -> Text
forall a. Name a -> Text
mkUId (Name () -> Text) -> Name () -> Text
forall a b. (a -> b) -> a -> b
$ Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
n))

  PFieldWildcard Annote
l ->
    Annote -> Text -> m (Text, Pat)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Pattern wildcards are not supported in records"




unqualText :: S.Name l -> T.Text
unqualText :: forall a. Name a -> Text
unqualText = \case
  Ident l
_ String
s  -> String -> Text
T.pack String
s
  Symbol l
_ String
s -> String -> Text
T.pack String
s

unqualQName :: QName l -> T.Text
unqualQName :: forall l. QName l -> Text
unqualQName = \case
  Qual l
_ ModuleName l
_ Name l
name -> Name l -> Text
forall a. Name a -> Text
unqualText Name l
name
  UnQual l
_ Name l
name -> Name l -> Text
forall a. Name a -> Text
unqualText Name l
name
  Special l
_ SpecialCon l
s   -> SpecialCon l -> Text
forall l. SpecialCon l -> Text
specialToText SpecialCon l
s  -- optional

specialToText :: SpecialCon l -> T.Text
specialToText :: forall l. SpecialCon l -> Text
specialToText = \case
  UnitCon l
_    -> Text
"()"
  ListCon l
_    -> Text
"[]"
  FunCon l
_     -> Text
"->"
  TupleCon l
_ Boxed
Boxed Int
n   -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  TupleCon l
_ Boxed
Unboxed Int
n -> Text
"(#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#)"
  Cons l
_       -> Text
":"
  UnboxedSingleCon l
_ -> Text
"(# #)"
  SpecialCon l
_ -> Text
"<SPECIAL>"


nameFromQName :: QName l -> S.Name l
nameFromQName :: forall l. QName l -> Name l
nameFromQName = \case
  Qual l
_ ModuleName l
_ Name l
n -> Name l
n
  UnQual l
_ Name l
n -> Name l
n
  Special l
_ SpecialCon l
_ -> String -> Name l
forall a. HasCallStack => String -> a
error String
"unexpected special name in field"


transFieldUpdate :: MonadError AstError m => Renamer -> RecEnv -> FieldUpdate Annote -> m (T.Text, M.Exp)
transFieldUpdate :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> FieldUpdate Annote -> m (Text, Exp)
transFieldUpdate Renamer
rn RecEnv
recEnv = \case
  FieldUpdate Annote
_ QName Annote
qname Exp Annote
e -> do
    e' <- Renamer -> RecEnv -> Exp Annote -> m Exp
forall (m :: * -> *).
MonadError AstError m =>
Renamer -> RecEnv -> Exp Annote -> m Exp
transExp Renamer
rn RecEnv
recEnv Exp Annote
e
    pure (unqualQName qname, e')

  FieldPun Annote
_ QName Annote
qname -> do
    let n :: Text
n = QName Annote -> Text
forall l. QName l -> Text
unqualQName QName Annote
qname
    (Text, Exp) -> m (Text, Exp)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
n, Annote -> Maybe Poly -> Maybe Ty -> Text -> Exp
M.Var (QName Annote -> Annote
forall l. QName l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QName Annote
qname) Maybe Poly
forall a. Maybe a
Nothing Maybe Ty
forall a. Maybe a
Nothing (Namespace -> Renamer -> Name Annote -> Text
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn (QName Annote -> Name Annote
forall l. QName l -> Name l
nameFromQName QName Annote
qname)))

  FieldWildcard Annote
l -> Annote -> Text -> m (Text, Exp)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Field wildcards are not supported"


stripModPrefix :: T.Text -> T.Text
stripModPrefix :: Text -> Text
stripModPrefix = [Text] -> Text
forall a. HasCallStack => [a] -> a
last ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"."