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 Data.List.NonEmpty qualified as NEL
import Data.Map qualified as M
import Language.PureScript.AST.Literals (Literal(..))
import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..))
import Language.PureScript.AST.Traversals (everythingOnValues)
import Language.PureScript.Comments (Comment)
import Language.PureScript.CoreFn.Ann (Ann, ssAnn)
import Language.PureScript.CoreFn.Binders (Binder(..))
import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard)
import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..))
import Language.PureScript.CoreFn.Module (Module(..))
import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue)
import Language.PureScript.Label (Label(..))
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual)
import Language.PureScript.PSString (PSString)
import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..))
import Language.PureScript.AST qualified as A
import Language.PureScript.Constants.Prim qualified as C
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
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
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)
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, [], 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. 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) 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
_ = []
exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> Expr Ann
exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
_ [Comment]
com Maybe SourceType
_ (A.Literal SourceSpan
ss Literal Expr
lit) =
forall a. a -> Literal (Expr a) -> Expr a
Literal (SourceSpan
ss, [Comment]
com, 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
_ (A.Accessor PSString
name Expr
v) =
forall a. a -> PSString -> Expr a -> Expr a
Accessor (SourceSpan
ss, [Comment]
com, 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 -> Maybe [PSString] -> [(PSString, Expr a)] -> Expr a
ObjectUpdate (SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing) (SourceSpan -> [Comment] -> Maybe SourceType -> Expr -> Expr Ann
exprToCoreFn SourceSpan
ss [] forall a. Maybe a
Nothing Expr
obj) (Maybe SourceType
ty forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. [PSString] -> Type a -> Maybe [PSString]
unchangedRecordFields (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(PSString, Expr)]
vs)) 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
where
unchangedRecordFields :: [PSString] -> Type a -> Maybe [PSString]
unchangedRecordFields :: forall a. [PSString] -> Type a -> Maybe [PSString]
unchangedRecordFields [PSString]
updated (TypeApp a
_ (TypeConstructor a
_ Qualified (ProperName 'TypeName)
C.Record) Type a
row) =
forall a. Type a -> Maybe [PSString]
collect Type a
row
where
collect :: Type a -> Maybe [PSString]
collect :: forall a. Type a -> Maybe [PSString]
collect (REmptyKinded a
_ Maybe (Type a)
_) = forall a. a -> Maybe a
Just []
collect (RCons a
_ (Label PSString
l) Type a
_ Type a
r) = (if PSString
l forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PSString]
updated then forall a. a -> a
id else (PSString
l forall a. a -> [a] -> [a]
:)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Type a -> Maybe [PSString]
collect Type a
r
collect Type a
_ = forall a. Maybe a
Nothing
unchangedRecordFields [PSString]
_ Type a
_ = forall a. Maybe a
Nothing
exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
_ (A.Abs (A.VarBinder SourceSpan
_ Ident
name) Expr
v) =
forall a. a -> Ident -> Expr a -> Expr a
Abs (SourceSpan
ss, [Comment]
com, 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
_ (A.App Expr
v1 Expr
v2) =
forall a. a -> Expr a -> Expr a -> Expr a
App (SourceSpan
ss, [Comment]
com, (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
_ (A.Unused Expr
_) =
forall a. a -> Qualified Ident -> Expr a
Var (SourceSpan
ss, [Comment]
com, forall a. Maybe a
Nothing) Qualified Ident
C.I_undefined
exprToCoreFn SourceSpan
_ [Comment]
com Maybe SourceType
_ (A.Var SourceSpan
ss Qualified Ident
ident) =
forall a. a -> Qualified Ident -> Expr a
Var (SourceSpan
ss, [Comment]
com, Qualified Ident -> Maybe Meta
getValueMeta Qualified Ident
ident) Qualified Ident
ident
exprToCoreFn SourceSpan
ss [Comment]
com Maybe SourceType
_ (A.IfThenElse Expr
v1 Expr
v2 Expr
v3) =
forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case (SourceSpan
ss, [Comment]
com, 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
_ (A.Constructor SourceSpan
ss Qualified (ProperName 'ConstructorName)
name) =
forall a. a -> Qualified Ident -> Expr a
Var (SourceSpan
ss, [Comment]
com, 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
_ (A.Case [Expr]
vs [CaseAlternative]
alts) =
forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case (SourceSpan
ss, [Comment]
com, 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
_ (A.Let WhereProvenance
w [Declaration]
ds Expr
v) =
forall a. a -> [Bind a] -> Expr a -> Expr a
Let (SourceSpan
ss, [Comment]
com, 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
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"
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 (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)
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) 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. 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) 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"
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
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
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"
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
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), ModuleName
name)
importToCoreFn Declaration
_ = forall a. Maybe a
Nothing
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
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
_) = []
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