module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

import Prelude
import Protolude (ordNub, orEmpty)

import Control.Arrow (second)

import Data.Function (on)
import Data.Maybe (mapMaybe)
import Data.Tuple (swap)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M

import Language.PureScript.AST.Literals
import Language.PureScript.AST.SourcePos
import Language.PureScript.AST.Traversals
import Language.PureScript.Comments
import Language.PureScript.CoreFn.Ann
import Language.PureScript.CoreFn.Binders
import Language.PureScript.CoreFn.Expr
import Language.PureScript.CoreFn.Meta
import Language.PureScript.CoreFn.Module
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Names
import Language.PureScript.Types
import qualified Language.PureScript.AST as A
import qualified Language.PureScript.Constants.Prim as C

-- | Desugars a module from AST to CoreFn representation.
moduleToCoreFn :: Environment -> A.Module -> Module Ann
moduleToCoreFn :: Environment -> Module -> Module Ann
moduleToCoreFn Environment
_ (A.Module SourceSpan
_ [Comment]
_ ModuleName
_ [Declaration]
_ Maybe [DeclarationRef]
Nothing) =
  forall a. HasCallStack => [Char] -> a
internalError [Char]
"Module exports were not elaborated before moduleToCoreFn"
moduleToCoreFn Environment
env (A.Module SourceSpan
modSS [Comment]
coms ModuleName
mn [Declaration]
decls (Just [DeclarationRef]
exps)) =
  let imports :: [(Ann, ModuleName)]
imports = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe (Ann, ModuleName)
importToCoreFn [Declaration]
decls forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceSpan -> Ann
ssAnn SourceSpan
modSS,) ([Declaration] -> [ModuleName]
findQualModules [Declaration]
decls)
      imports' :: [(Ann, ModuleName)]
imports' = [(Ann, ModuleName)] -> [(Ann, ModuleName)]
dedupeImports [(Ann, ModuleName)]
imports
      exps' :: [Ident]
exps' = forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DeclarationRef -> [Ident]
exportToCoreFn [DeclarationRef]
exps
      reExps :: Map ModuleName [Ident]
reExps = forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith forall a. [a] -> [a] -> [a]
(++) (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModuleName, DeclarationRef) -> Map ModuleName [Ident]
reExportsToCoreFn forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclarationRef -> Maybe (ModuleName, DeclarationRef)
toReExportRef) [DeclarationRef]
exps)
      externs :: [Ident]
externs = forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe Ident
externToCoreFn [Declaration]
decls
      decls' :: [Bind Ann]
decls' = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [Bind Ann]
declToCoreFn [Declaration]
decls
  in forall a.
SourceSpan
-> [Comment]
-> ModuleName
-> [Char]
-> [(a, ModuleName)]
-> [Ident]
-> Map ModuleName [Ident]
-> [Ident]
-> [Bind a]
-> Module a
Module SourceSpan
modSS [Comment]
coms ModuleName
mn (SourceSpan -> [Char]
spanName SourceSpan
modSS) [(Ann, ModuleName)]
imports' [Ident]
exps' Map ModuleName [Ident]
reExps [Ident]
externs [Bind Ann]
decls'
  where
  -- | Creates a map from a module name to the re-export references defined in
  -- that module.
  reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident]
  reExportsToCoreFn :: (ModuleName, DeclarationRef) -> Map ModuleName [Ident]
reExportsToCoreFn (ModuleName
mn', DeclarationRef
ref') = forall k a. k -> a -> Map k a
M.singleton ModuleName
mn' (DeclarationRef -> [Ident]
exportToCoreFn DeclarationRef
ref')

  toReExportRef :: A.DeclarationRef -> Maybe (ModuleName, A.DeclarationRef)
  toReExportRef :: DeclarationRef -> Maybe (ModuleName, DeclarationRef)
toReExportRef (A.ReExportRef SourceSpan
_ ExportSource
src DeclarationRef
ref) =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (, DeclarationRef
ref)
        (ExportSource -> Maybe ModuleName
A.exportSourceImportedFrom ExportSource
src)
  toReExportRef DeclarationRef
_ = forall a. Maybe a
Nothing

  -- | Remove duplicate imports
  dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)]
  dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)]
dedupeImports = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> (b, a)
swap

  ssA :: SourceSpan -> Ann
  ssA :: SourceSpan -> Ann
ssA SourceSpan
ss = (SourceSpan
ss, [], forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)

  -- | Desugars member declarations from AST to CoreFn representation.
  declToCoreFn :: A.Declaration -> [Bind Ann]
  declToCoreFn :: Declaration -> [Bind Ann]
declToCoreFn (A.DataDeclaration (SourceSpan
ss, [Comment]
com) DataDeclType
Newtype ProperName 'TypeName
_ [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration
ctor]) =
    [forall a. a -> Ident -> Expr a -> Bind a
NonRec (SourceSpan
ss, [], forall a. Maybe a
Nothing, Maybe Meta
declMeta) (forall (a :: ProperNameType). ProperName a -> Ident
properToIdent forall a b. (a -> b) -> a -> b
$ DataConstructorDeclaration -> ProperName 'ConstructorName
A.dataCtorName DataConstructorDeclaration
ctor) forall a b. (a -> b) -> a -> b
$
      forall a. a -> Ident -> Expr a -> Expr a
Abs (SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Meta
IsNewtype) (Text -> Ident
Ident Text
"x") (forall a. a -> Qualified Ident -> Expr a
Var (SourceSpan -> Ann
ssAnn SourceSpan
ss) forall a b. (a -> b) -> a -> b
$ forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos (Text -> Ident
Ident Text
"x"))]
    where
    declMeta :: Maybe Meta
declMeta = forall (a :: ProperNameType). ProperName a -> Bool
isDictTypeName (DataConstructorDeclaration -> ProperName 'ConstructorName
A.dataCtorName DataConstructorDeclaration
ctor) forall (f :: * -> *) a. Alternative f => Bool -> a -> f a
`orEmpty` Meta
IsTypeClassConstructor
  declToCoreFn d :: Declaration
d@(A.DataDeclaration (SourceSpan, [Comment])
_ DataDeclType
Newtype ProperName 'TypeName
_ [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration]
_) =
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Found newtype with multiple constructors: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Declaration
d
  declToCoreFn (A.DataDeclaration (SourceSpan
ss, [Comment]
com) DataDeclType
Data ProperName 'TypeName
tyName [(Text, Maybe SourceType)]
_ [DataConstructorDeclaration]
ctors) =
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [DataConstructorDeclaration]
ctors forall a b. (a -> b) -> a -> b
$ \DataConstructorDeclaration
ctorDecl ->
      let
        ctor :: ProperName 'ConstructorName
ctor = DataConstructorDeclaration -> ProperName 'ConstructorName
A.dataCtorName DataConstructorDeclaration
ctorDecl
        (DataDeclType
_, ProperName 'TypeName
_, SourceType
_, [Ident]
fields) = Environment
-> Qualified (ProperName 'ConstructorName)
-> (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
lookupConstructor Environment
env (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
mn) ProperName 'ConstructorName
ctor)
      in forall a. a -> Ident -> Expr a -> Bind a
NonRec (SourceSpan -> Ann
ssA SourceSpan
ss) (forall (a :: ProperNameType). ProperName a -> Ident
properToIdent ProperName 'ConstructorName
ctor) forall a b. (a -> b) -> a -> b
$ forall a.
a
-> ProperName 'TypeName
-> ProperName 'ConstructorName
-> [Ident]
-> Expr a
Constructor (SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) ProperName 'TypeName
tyName ProperName 'ConstructorName
ctor [Ident]
fields
  declToCoreFn (A.DataBindingGroupDeclaration NonEmpty Declaration
ds) =
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [Bind Ann]
declToCoreFn NonEmpty Declaration
ds
  declToCoreFn (A.ValueDecl (SourceSpan
ss, [Comment]
com) Ident
name NameKind
_ [Binder]
_ [A.MkUnguarded Expr
e]) =
    [forall a. a -> Ident -> Expr a -> Bind a
NonRec (SourceSpan -> Ann
ssA SourceSpan
ss) Ident
name (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [Comment]
com forall a. Maybe a
Nothing Expr
e)]
  declToCoreFn (A.BindingGroupDeclaration NonEmpty (((SourceSpan, [Comment]), Ident), NameKind, Expr)
ds) =
    [forall a. [((a, Ident), Expr a)] -> Bind a
Rec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(((SourceSpan
ss, [Comment]
com), Ident
name), NameKind
_, Expr
e) -> ((SourceSpan -> Ann
ssA SourceSpan
ss, Ident
name), SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [Comment]
com forall a. Maybe a
Nothing Expr
e)) NonEmpty (((SourceSpan, [Comment]), Ident), NameKind, Expr)
ds]
  declToCoreFn Declaration
_ = []

  -- | Desugars expressions from AST to CoreFn representation.
  exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> Expr Ann
  exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
_ [Comment]
com Maybe SourceType
ty (A.Literal SourceSpan
ss Literal Expr
lit) =
    forall a. a -> Literal (Expr a) -> Expr a
Literal (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [Comment]
com forall a. Maybe a
Nothing) Literal Expr
lit)
  exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
ty (A.Accessor PSString
name Expr
v) =
    forall a. a -> PSString -> Expr a -> Expr a
Accessor (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, forall a. Maybe a
Nothing) PSString
name (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
v)
  exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
ty (A.ObjectUpdate Expr
obj [(PSString, Expr)]
vs) =
    forall a. a -> Expr a -> [(PSString, Expr a)] -> Expr a
ObjectUpdate (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, forall a. Maybe a
Nothing) (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
obj) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing)) [(PSString, Expr)]
vs
  exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
ty (A.Abs (A.VarBinder SourceSpan
_ Ident
name) Expr
v) =
    forall a. a -> Ident -> Expr a -> Expr a
Abs (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, forall a. Maybe a
Nothing) Ident
name (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
v)
  exprToCoreFn SourceSpan
_ [Comment]
_ Maybe SourceType
_ (A.Abs Binder
_ Expr
_) =
    forall a. HasCallStack => [Char] -> a
internalError [Char]
"Abs with Binder argument was not desugared before exprToCoreFn mn"
  exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
ty (A.App Expr
v1 Expr
v2) =
    forall a. a -> Expr a -> Expr a -> Expr a
App (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, (Expr -> Bool
isDictCtor Expr
v1 Bool -> Bool -> Bool
|| Expr -> Bool
isSynthetic Expr
v2) forall (f :: * -> *) a. Alternative f => Bool -> a -> f a
`orEmpty` Meta
IsSyntheticApp) Expr Ann
v1' Expr Ann
v2'
    where
    v1' :: Expr Ann
v1' = SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
v1
    v2' :: Expr Ann
v2' = SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
v2
    isDictCtor :: Expr -> Bool
isDictCtor = \case
      A.Constructor SourceSpan
_ (Qualified QualifiedBy
_ ProperName 'ConstructorName
name) -> forall (a :: ProperNameType). ProperName a -> Bool
isDictTypeName ProperName 'ConstructorName
name
      Expr
_ -> Bool
False
    isSynthetic :: Expr -> Bool
isSynthetic = \case
      A.App Expr
v3 Expr
v4            -> Expr -> Bool
isDictCtor Expr
v3 Bool -> Bool -> Bool
|| Expr -> Bool
isSynthetic Expr
v3 Bool -> Bool -> Bool
&& Expr -> Bool
isSynthetic Expr
v4
      A.Accessor PSString
_ Expr
v3        -> Expr -> Bool
isSynthetic Expr
v3
      A.Var SourceSpan
NullSourceSpan Qualified Ident
_ -> Bool
True
      A.Unused{}             -> Bool
True
      Expr
_                      -> Bool
False
  exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
ty (A.Unused Expr
_) =
    forall a. a -> Qualified Ident -> Expr a
Var (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, forall a. Maybe a
Nothing) Qualified Ident
C.I_undefined
  exprToCoreFn SourceSpan
_ [Comment]
com Maybe SourceType
ty (A.Var SourceSpan
ss Qualified Ident
ident) =
    forall a. a -> Qualified Ident -> Expr a
Var (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, Qualified Ident -> Maybe Meta
getValueMeta Qualified Ident
ident) Qualified Ident
ident
  exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
ty (A.IfThenElse Expr
v1 Expr
v2 Expr
v3) =
    forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, forall a. Maybe a
Nothing) [SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
v1]
      [ forall a.
[Binder a]
-> Either [(Guard a, Guard a)] (Guard a) -> CaseAlternative a
CaseAlternative [forall a. a -> Literal (Binder a) -> Binder a
LiteralBinder (SourceSpan -> Ann
ssAnn SourceSpan
ss) forall a b. (a -> b) -> a -> b
$ forall a. Bool -> Literal a
BooleanLiteral Bool
True]
                        (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
v2)
      , forall a.
[Binder a]
-> Either [(Guard a, Guard a)] (Guard a) -> CaseAlternative a
CaseAlternative [forall a. a -> Binder a
NullBinder (SourceSpan -> Ann
ssAnn SourceSpan
ss)]
                        (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
v3) ]
  exprToCoreFn SourceSpan
_ [Comment]
com Maybe SourceType
ty (A.Constructor SourceSpan
ss Qualified (ProperName 'ConstructorName)
name) =
    forall a. a -> Qualified Ident -> Expr a
Var (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ConstructorName) -> Meta
getConstructorMeta Qualified (ProperName 'ConstructorName)
name) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType). ProperName a -> Ident
properToIdent Qualified (ProperName 'ConstructorName)
name
  exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
ty (A.Case [Expr]
vs [CaseAlternative]
alts) =
    forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing) [Expr]
vs) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceSpan -> CaseAlternative -> CaseAlternative Ann
altToCoreFn SourceSpan
ss) [CaseAlternative]
alts)
  exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
_ (A.TypedValue Bool
_ Expr
v SourceType
ty) =
    SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [Comment]
com (forall a. a -> Maybe a
Just SourceType
ty) Expr
v
  exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
ty (A.Let WhereProvenance
w [Declaration]
ds Expr
v) =
    forall a. a -> [Bind a] -> Expr a -> Expr a
Let (SourceSpan
ss, [Comment]
com, Maybe SourceType
ty, WhereProvenance -> Maybe Meta
getLetMeta WhereProvenance
w) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Declaration -> [Bind Ann]
declToCoreFn [Declaration]
ds) (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
v)
  exprToCoreFn SourceSpan
_ [Comment]
com Maybe SourceType
ty (A.PositionedValue SourceSpan
ss [Comment]
com1 Expr
v) =
    SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss ([Comment]
com forall a. [a] -> [a] -> [a]
++ [Comment]
com1) Maybe SourceType
ty Expr
v
  exprToCoreFn SourceSpan
_ [Comment]
_ Maybe SourceType
_ Expr
e =
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected value in exprToCoreFn mn: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Expr
e

  -- | Desugars case alternatives from AST to CoreFn representation.
  altToCoreFn :: SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
  altToCoreFn :: SourceSpan -> CaseAlternative -> CaseAlternative Ann
altToCoreFn SourceSpan
ss (A.CaseAlternative [Binder]
bs [GuardedExpr]
vs) = forall a.
[Binder a]
-> Either [(Guard a, Guard a)] (Guard a) -> CaseAlternative a
CaseAlternative (forall a b. (a -> b) -> [a] -> [b]
map (SourceSpan -> [Comment] -> Binder -> Binder Ann
binderToCoreFn SourceSpan
ss []) [Binder]
bs) ([GuardedExpr] -> Either [(Expr Ann, Expr Ann)] (Expr Ann)
go [GuardedExpr]
vs)
    where
    go :: [A.GuardedExpr] -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
    go :: [GuardedExpr] -> Either [(Expr Ann, Expr Ann)] (Expr Ann)
go [A.MkUnguarded Expr
e]
      = forall a b. b -> Either a b
Right (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
e)
    go [GuardedExpr]
gs
      = forall a b. a -> Either a b
Left [ (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
cond, SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
e)
             | A.GuardedExpr [Guard]
g Expr
e <- [GuardedExpr]
gs
             , let cond :: Expr
cond = [Guard] -> Expr
guardToExpr [Guard]
g
             ]

    guardToExpr :: [Guard] -> Expr
guardToExpr [A.ConditionGuard Expr
cond] = Expr
cond
    guardToExpr [Guard]
_ = forall a. HasCallStack => [Char] -> a
internalError [Char]
"Guard not correctly desugared"

  -- | Desugars case binders from AST to CoreFn representation.
  binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann
  binderToCoreFn :: SourceSpan -> [Comment] -> Binder -> Binder Ann
binderToCoreFn SourceSpan
_ [Comment]
com (A.LiteralBinder SourceSpan
ss Literal Binder
lit) =
    forall a. a -> Literal (Binder a) -> Binder a
LiteralBinder (SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceSpan -> [Comment] -> Binder -> Binder Ann
binderToCoreFn SourceSpan
ss [Comment]
com) Literal Binder
lit)
  binderToCoreFn SourceSpan
ss [Comment]
com Binder
A.NullBinder =
    forall a. a -> Binder a
NullBinder (SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
  binderToCoreFn SourceSpan
_ [Comment]
com (A.VarBinder SourceSpan
ss Ident
name) =
    forall a. a -> Ident -> Binder a
VarBinder (SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) Ident
name
  binderToCoreFn SourceSpan
_ [Comment]
com (A.ConstructorBinder SourceSpan
ss dctor :: Qualified (ProperName 'ConstructorName)
dctor@(Qualified QualifiedBy
mn' ProperName 'ConstructorName
_) [Binder]
bs) =
    let (DataDeclType
_, ProperName 'TypeName
tctor, SourceType
_, [Ident]
_) = Environment
-> Qualified (ProperName 'ConstructorName)
-> (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
lookupConstructor Environment
env Qualified (ProperName 'ConstructorName)
dctor
    in forall a.
a
-> Qualified (ProperName 'TypeName)
-> Qualified (ProperName 'ConstructorName)
-> [Binder a]
-> Binder a
ConstructorBinder (SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Qualified (ProperName 'ConstructorName) -> Meta
getConstructorMeta Qualified (ProperName 'ConstructorName)
dctor) (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
mn' ProperName 'TypeName
tctor) Qualified (ProperName 'ConstructorName)
dctor (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceSpan -> [Comment] -> Binder -> Binder Ann
binderToCoreFn SourceSpan
ss []) [Binder]
bs)
  binderToCoreFn SourceSpan
_ [Comment]
com (A.NamedBinder SourceSpan
ss Ident
name Binder
b) =
    forall a. a -> Ident -> Binder a -> Binder a
NamedBinder (SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) Ident
name (SourceSpan -> [Comment] -> Binder -> Binder Ann
binderToCoreFn SourceSpan
ss [] Binder
b)
  binderToCoreFn SourceSpan
_ [Comment]
com (A.PositionedBinder SourceSpan
ss [Comment]
com1 Binder
b) =
    SourceSpan -> [Comment] -> Binder -> Binder Ann
binderToCoreFn SourceSpan
ss ([Comment]
com forall a. [a] -> [a] -> [a]
++ [Comment]
com1) Binder
b
  binderToCoreFn SourceSpan
ss [Comment]
com (A.TypedBinder SourceType
_ Binder
b) =
    SourceSpan -> [Comment] -> Binder -> Binder Ann
binderToCoreFn SourceSpan
ss [Comment]
com Binder
b
  binderToCoreFn SourceSpan
_ [Comment]
_ A.OpBinder{} =
    forall a. HasCallStack => [Char] -> a
internalError [Char]
"OpBinder should have been desugared before binderToCoreFn"
  binderToCoreFn SourceSpan
_ [Comment]
_ A.BinaryNoParensBinder{} =
    forall a. HasCallStack => [Char] -> a
internalError [Char]
"BinaryNoParensBinder should have been desugared before binderToCoreFn"
  binderToCoreFn SourceSpan
_ [Comment]
_ A.ParensInBinder{} =
    forall a. HasCallStack => [Char] -> a
internalError [Char]
"ParensInBinder should have been desugared before binderToCoreFn"

  -- | Gets metadata for let bindings.
  getLetMeta :: A.WhereProvenance -> Maybe Meta
  getLetMeta :: WhereProvenance -> Maybe Meta
getLetMeta WhereProvenance
A.FromWhere = forall a. a -> Maybe a
Just Meta
IsWhere
  getLetMeta WhereProvenance
A.FromLet = forall a. Maybe a
Nothing

  -- | Gets metadata for values.
  getValueMeta :: Qualified Ident -> Maybe Meta
  getValueMeta :: Qualified Ident -> Maybe Meta
getValueMeta Qualified Ident
name =
    case Environment
-> Qualified Ident -> Maybe (SourceType, NameKind, NameVisibility)
lookupValue Environment
env Qualified Ident
name of
      Just (SourceType
_, NameKind
External, NameVisibility
_) -> forall a. a -> Maybe a
Just Meta
IsForeign
      Maybe (SourceType, NameKind, NameVisibility)
_ -> forall a. Maybe a
Nothing

  -- | Gets metadata for data constructors.
  getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta
  getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta
getConstructorMeta Qualified (ProperName 'ConstructorName)
ctor =
    case Environment
-> Qualified (ProperName 'ConstructorName)
-> (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
lookupConstructor Environment
env Qualified (ProperName 'ConstructorName)
ctor of
      (DataDeclType
Newtype, ProperName 'TypeName
_, SourceType
_, [Ident]
_) -> Meta
IsNewtype
      dc :: (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dc@(DataDeclType
Data, ProperName 'TypeName
_, SourceType
_, [Ident]
fields) ->
        let constructorType :: ConstructorType
constructorType = if (Qualified (ProperName 'ConstructorName),
 (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
-> Int
numConstructors (Qualified (ProperName 'ConstructorName)
ctor, (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dc) forall a. Eq a => a -> a -> Bool
== Int
1 then ConstructorType
ProductType else ConstructorType
SumType
        in ConstructorType -> [Ident] -> Meta
IsConstructor ConstructorType
constructorType [Ident]
fields
    where

    numConstructors
      :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
      -> Int
    numConstructors :: (Qualified (ProperName 'ConstructorName),
 (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
-> Int
numConstructors (Qualified (ProperName 'ConstructorName),
 (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
ty = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Qualified (ProperName 'ConstructorName),
 (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
-> (ModuleName, ProperName 'TypeName)
typeConstructor) (Qualified (ProperName 'ConstructorName),
 (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
ty) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ Environment
-> Map
     (Qualified (ProperName 'ConstructorName))
     (DataDeclType, ProperName 'TypeName, SourceType, [Ident])
dataConstructors Environment
env

    typeConstructor
      :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
      -> (ModuleName, ProperName 'TypeName)
    typeConstructor :: (Qualified (ProperName 'ConstructorName),
 (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
-> (ModuleName, ProperName 'TypeName)
typeConstructor (Qualified (ByModuleName ModuleName
mn') ProperName 'ConstructorName
_, (DataDeclType
_, ProperName 'TypeName
tyCtor, SourceType
_, [Ident]
_)) = (ModuleName
mn', ProperName 'TypeName
tyCtor)
    typeConstructor (Qualified (ProperName 'ConstructorName),
 (DataDeclType, ProperName 'TypeName, SourceType, [Ident]))
_ = forall a. HasCallStack => [Char] -> a
internalError [Char]
"Invalid argument to typeConstructor"

-- | Find module names from qualified references to values. This is used to
-- ensure instances are imported from any module that is referenced by the
-- current module, not just from those that are imported explicitly (#667).
findQualModules :: [A.Declaration] -> [ModuleName]
findQualModules :: [Declaration] -> [ModuleName]
findQualModules [Declaration]
decls =
  let (Declaration -> [ModuleName]
f, Expr -> [ModuleName]
_, Binder -> [ModuleName]
_, CaseAlternative -> [ModuleName]
_, DoNotationElement -> [ModuleName]
_) = forall r.
(r -> r -> r)
-> (Declaration -> r)
-> (Expr -> r)
-> (Binder -> r)
-> (CaseAlternative -> r)
-> (DoNotationElement -> r)
-> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r,
    DoNotationElement -> r)
everythingOnValues forall a. [a] -> [a] -> [a]
(++) Declaration -> [ModuleName]
fqDecls Expr -> [ModuleName]
fqValues Binder -> [ModuleName]
fqBinders (forall a b. a -> b -> a
const []) (forall a b. a -> b -> a
const [])
  in Declaration -> [ModuleName]
f forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
`concatMap` [Declaration]
decls
  where
  fqDecls :: A.Declaration -> [ModuleName]
  fqDecls :: Declaration -> [ModuleName]
fqDecls (A.TypeInstanceDeclaration (SourceSpan, [Comment])
_ (SourceSpan, [Comment])
_ ChainId
_ Integer
_ Either Text Ident
_ [SourceConstraint]
_ Qualified (ProperName 'ClassName)
q [SourceType]
_ TypeInstanceBody
_) = forall a. Qualified a -> [ModuleName]
getQual' Qualified (ProperName 'ClassName)
q
  fqDecls (A.ValueFixityDeclaration (SourceSpan, [Comment])
_ Fixity
_ Qualified (Either Ident (ProperName 'ConstructorName))
q OpName 'ValueOpName
_) = forall a. Qualified a -> [ModuleName]
getQual' Qualified (Either Ident (ProperName 'ConstructorName))
q
  fqDecls (A.TypeFixityDeclaration (SourceSpan, [Comment])
_ Fixity
_ Qualified (ProperName 'TypeName)
q OpName 'TypeOpName
_) = forall a. Qualified a -> [ModuleName]
getQual' Qualified (ProperName 'TypeName)
q
  fqDecls Declaration
_ = []

  fqValues :: A.Expr -> [ModuleName]
  fqValues :: Expr -> [ModuleName]
fqValues (A.Var SourceSpan
_ Qualified Ident
q) = forall a. Qualified a -> [ModuleName]
getQual' Qualified Ident
q
  fqValues (A.Constructor SourceSpan
_ Qualified (ProperName 'ConstructorName)
q) = forall a. Qualified a -> [ModuleName]
getQual' Qualified (ProperName 'ConstructorName)
q
  fqValues Expr
_ = []

  fqBinders :: A.Binder -> [ModuleName]
  fqBinders :: Binder -> [ModuleName]
fqBinders (A.ConstructorBinder SourceSpan
_ Qualified (ProperName 'ConstructorName)
q [Binder]
_) = forall a. Qualified a -> [ModuleName]
getQual' Qualified (ProperName 'ConstructorName)
q
  fqBinders Binder
_ = []

  getQual' :: Qualified a -> [ModuleName]
  getQual' :: forall a. Qualified a -> [ModuleName]
getQual' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Qualified a -> Maybe ModuleName
getQual

-- | Desugars import declarations from AST to CoreFn representation.
importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName)
importToCoreFn :: Declaration -> Maybe (Ann, ModuleName)
importToCoreFn (A.ImportDeclaration (SourceSpan
ss, [Comment]
com) ModuleName
name ImportDeclarationType
_ Maybe ModuleName
_) = forall a. a -> Maybe a
Just ((SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing), ModuleName
name)
importToCoreFn Declaration
_ = forall a. Maybe a
Nothing

-- | Desugars foreign declarations from AST to CoreFn representation.
externToCoreFn :: A.Declaration -> Maybe Ident
externToCoreFn :: Declaration -> Maybe Ident
externToCoreFn (A.ExternDeclaration (SourceSpan, [Comment])
_ Ident
name SourceType
_) = forall a. a -> Maybe a
Just Ident
name
externToCoreFn Declaration
_ = forall a. Maybe a
Nothing

-- | Desugars export declarations references from AST to CoreFn representation.
-- CoreFn modules only export values, so all data constructors, instances and
-- values are flattened into one list.
exportToCoreFn :: A.DeclarationRef -> [Ident]
exportToCoreFn :: DeclarationRef -> [Ident]
exportToCoreFn (A.TypeRef SourceSpan
_ ProperName 'TypeName
_ (Just [ProperName 'ConstructorName]
dctors)) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: ProperNameType). ProperName a -> Ident
properToIdent [ProperName 'ConstructorName]
dctors
exportToCoreFn (A.TypeRef SourceSpan
_ ProperName 'TypeName
_ Maybe [ProperName 'ConstructorName]
Nothing) = []
exportToCoreFn (A.TypeOpRef SourceSpan
_ OpName 'TypeOpName
_) = []
exportToCoreFn (A.ValueRef SourceSpan
_ Ident
name) = [Ident
name]
exportToCoreFn (A.ValueOpRef SourceSpan
_ OpName 'ValueOpName
_) = []
exportToCoreFn (A.TypeClassRef SourceSpan
_ ProperName 'ClassName
_) = []
exportToCoreFn (A.TypeInstanceRef SourceSpan
_ Ident
name NameSource
_) = [Ident
name]
exportToCoreFn (A.ModuleRef SourceSpan
_ ModuleName
_) = []
exportToCoreFn (A.ReExportRef SourceSpan
_ ExportSource
_ DeclarationRef
_) = []

-- | Converts a ProperName to an Ident.
properToIdent :: ProperName a -> Ident
properToIdent :: forall (a :: ProperNameType). ProperName a -> Ident
properToIdent = Text -> Ident
Ident forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: ProperNameType). ProperName a -> Text
runProperName