{-# LANGUAGE Safe #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
module Cryptol.TypeCheck.AST
( module Cryptol.TypeCheck.AST
, Name()
, TFun(..)
, Selector(..)
, Import, ImportG(..), ImpName(..)
, ImportSpec(..)
, ExportType(..)
, ExportSpec(..), isExportedBind, isExportedType, isExported
, Pragma(..)
, Fixity(..)
, PrimMap(..)
, module Cryptol.TypeCheck.Type
) where
import Data.Maybe(mapMaybe)
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.Ident (Ident,isInfixIdent,ModName,PrimIdent,prelPrim)
import Cryptol.Parser.Position(Located,Range,HasLoc(..))
import Cryptol.ModuleSystem.Name
import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Exports(ExportSpec(..)
, isExportedBind, isExportedType, isExported)
import Cryptol.Parser.AST ( Selector(..),Pragma(..)
, Import
, ImportG(..), ImportSpec(..), ExportType(..)
, Fixity(..)
, ImpName(..)
)
import Cryptol.Utils.RecordMap
import Cryptol.TypeCheck.FFI.FFIType
import Cryptol.TypeCheck.PP
import Cryptol.TypeCheck.Type
import GHC.Generics (Generic)
import Control.DeepSeq
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Text (Text)
data TCTopEntity =
TCTopModule (ModuleG ModName)
| TCTopSignature ModName ModParamNames
deriving (Int -> TCTopEntity -> ShowS
[TCTopEntity] -> ShowS
TCTopEntity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TCTopEntity] -> ShowS
$cshowList :: [TCTopEntity] -> ShowS
show :: TCTopEntity -> String
$cshow :: TCTopEntity -> String
showsPrec :: Int -> TCTopEntity -> ShowS
$cshowsPrec :: Int -> TCTopEntity -> ShowS
Show, forall x. Rep TCTopEntity x -> TCTopEntity
forall x. TCTopEntity -> Rep TCTopEntity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TCTopEntity x -> TCTopEntity
$cfrom :: forall x. TCTopEntity -> Rep TCTopEntity x
Generic, TCTopEntity -> ()
forall a. (a -> ()) -> NFData a
rnf :: TCTopEntity -> ()
$crnf :: TCTopEntity -> ()
NFData)
tcTopEntitytName :: TCTopEntity -> ModName
tcTopEntitytName :: TCTopEntity -> ModName
tcTopEntitytName TCTopEntity
ent =
case TCTopEntity
ent of
TCTopModule ModuleG ModName
m -> forall mname. ModuleG mname -> mname
mName ModuleG ModName
m
TCTopSignature ModName
m ModParamNames
_ -> ModName
m
tcTopEntityToModule :: TCTopEntity -> Module
tcTopEntityToModule :: TCTopEntity -> ModuleG ModName
tcTopEntityToModule TCTopEntity
ent =
case TCTopEntity
ent of
TCTopModule ModuleG ModName
m -> ModuleG ModName
m
TCTopSignature {} -> forall a. HasCallStack => String -> [String] -> a
panic String
"tcTopEntityToModule" [ String
"Not a module" ]
data ModuleG mname =
Module { forall mname. ModuleG mname -> mname
mName :: !mname
, forall mname. ModuleG mname -> Maybe Text
mDoc :: !(Maybe Text)
, forall mname. ModuleG mname -> ExportSpec Name
mExports :: ExportSpec Name
, forall mname. ModuleG mname -> Map Name ModTParam
mParamTypes :: Map Name ModTParam
, forall mname. ModuleG mname -> Map Name ModVParam
mParamFuns :: Map Name ModVParam
, forall mname. ModuleG mname -> [Located Prop]
mParamConstraints :: [Located Prop]
, forall mname. ModuleG mname -> FunctorParams
mParams :: FunctorParams
, forall mname. ModuleG mname -> Map Name (ModuleG Name)
mFunctors :: Map Name (ModuleG Name)
, forall mname. ModuleG mname -> Set Name
mNested :: !(Set Name)
, forall mname. ModuleG mname -> Map Name TySyn
mTySyns :: Map Name TySyn
, forall mname. ModuleG mname -> Map Name Newtype
mNewtypes :: Map Name Newtype
, forall mname. ModuleG mname -> Map Name AbstractType
mPrimTypes :: Map Name AbstractType
, forall mname. ModuleG mname -> [DeclGroup]
mDecls :: [DeclGroup]
, forall mname. ModuleG mname -> Map Name (IfaceNames Name)
mSubmodules :: Map Name (IfaceNames Name)
, forall mname. ModuleG mname -> Map Name ModParamNames
mSignatures :: !(Map Name ModParamNames)
} deriving (Int -> ModuleG mname -> ShowS
forall mname. Show mname => Int -> ModuleG mname -> ShowS
forall mname. Show mname => [ModuleG mname] -> ShowS
forall mname. Show mname => ModuleG mname -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleG mname] -> ShowS
$cshowList :: forall mname. Show mname => [ModuleG mname] -> ShowS
show :: ModuleG mname -> String
$cshow :: forall mname. Show mname => ModuleG mname -> String
showsPrec :: Int -> ModuleG mname -> ShowS
$cshowsPrec :: forall mname. Show mname => Int -> ModuleG mname -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall mname x. Rep (ModuleG mname) x -> ModuleG mname
forall mname x. ModuleG mname -> Rep (ModuleG mname) x
$cto :: forall mname x. Rep (ModuleG mname) x -> ModuleG mname
$cfrom :: forall mname x. ModuleG mname -> Rep (ModuleG mname) x
Generic, forall mname. NFData mname => ModuleG mname -> ()
forall a. (a -> ()) -> NFData a
rnf :: ModuleG mname -> ()
$crnf :: forall mname. NFData mname => ModuleG mname -> ()
NFData)
emptyModule :: mname -> ModuleG mname
emptyModule :: forall mname. mname -> ModuleG mname
emptyModule mname
nm =
Module
{ mName :: mname
mName = mname
nm
, mDoc :: Maybe Text
mDoc = forall a. Maybe a
Nothing
, mExports :: ExportSpec Name
mExports = forall a. Monoid a => a
mempty
, mParams :: FunctorParams
mParams = forall a. Monoid a => a
mempty
, mParamTypes :: Map Name ModTParam
mParamTypes = forall a. Monoid a => a
mempty
, mParamConstraints :: [Located Prop]
mParamConstraints = forall a. Monoid a => a
mempty
, mParamFuns :: Map Name ModVParam
mParamFuns = forall a. Monoid a => a
mempty
, mNested :: Set Name
mNested = forall a. Monoid a => a
mempty
, mTySyns :: Map Name TySyn
mTySyns = forall a. Monoid a => a
mempty
, mNewtypes :: Map Name Newtype
mNewtypes = forall a. Monoid a => a
mempty
, mPrimTypes :: Map Name AbstractType
mPrimTypes = forall a. Monoid a => a
mempty
, mDecls :: [DeclGroup]
mDecls = forall a. Monoid a => a
mempty
, mFunctors :: Map Name (ModuleG Name)
mFunctors = forall a. Monoid a => a
mempty
, mSubmodules :: Map Name (IfaceNames Name)
mSubmodules = forall a. Monoid a => a
mempty
, mSignatures :: Map Name ModParamNames
mSignatures = forall a. Monoid a => a
mempty
}
findForeignDecls :: ModuleG mname -> [(Name, FFIFunType)]
findForeignDecls :: forall mname. ModuleG mname -> [(Name, FFIFunType)]
findForeignDecls = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DeclGroup -> Maybe (Name, FFIFunType)
getForeign forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mname. ModuleG mname -> [DeclGroup]
mDecls
where getForeign :: DeclGroup -> Maybe (Name, FFIFunType)
getForeign (NonRecursive Decl { Name
dName :: Decl -> Name
dName :: Name
dName, dDefinition :: Decl -> DeclDef
dDefinition = DForeign FFIFunType
ffiType })
= forall a. a -> Maybe a
Just (Name
dName, FFIFunType
ffiType)
getForeign DeclGroup
_ = forall a. Maybe a
Nothing
findForeignDeclsInFunctors :: ModuleG mname -> [Name]
findForeignDeclsInFunctors :: forall mname. ModuleG mname -> [Name]
findForeignDeclsInFunctors = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall mname. ModuleG mname -> [Name]
fromM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mname. ModuleG mname -> Map Name (ModuleG Name)
mFunctors
where
fromM :: ModuleG mname -> [Name]
fromM ModuleG mname
m = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall mname. ModuleG mname -> [(Name, FFIFunType)]
findForeignDecls ModuleG mname
m) forall a. [a] -> [a] -> [a]
++ forall mname. ModuleG mname -> [Name]
findForeignDeclsInFunctors ModuleG mname
m
type Module = ModuleG ModName
isParametrizedModule :: ModuleG mname -> Bool
isParametrizedModule :: forall mname. ModuleG mname -> Bool
isParametrizedModule ModuleG mname
m = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall mname. ModuleG mname -> FunctorParams
mParams ModuleG mname
m) Bool -> Bool -> Bool
&&
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall mname. ModuleG mname -> Map Name ModTParam
mParamTypes ModuleG mname
m) Bool -> Bool -> Bool
&&
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall mname. ModuleG mname -> [Located Prop]
mParamConstraints ModuleG mname
m) Bool -> Bool -> Bool
&&
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall mname. ModuleG mname -> Map Name ModVParam
mParamFuns ModuleG mname
m))
data Expr = EList [Expr] Type
| ETuple [Expr]
| ERec (RecordMap Ident Expr)
| ESel Expr Selector
| ESet Type Expr Selector Expr
| EIf Expr Expr Expr
| EComp Type Type Expr [[Match]]
| EVar Name
| ETAbs TParam Expr
| ETApp Expr Type
| EApp Expr Expr
| EAbs Name Type Expr
| ELocated Range Expr
| EProofAbs Prop Expr
| EProofApp Expr
| EWhere Expr [DeclGroup]
| EPropGuards [([Prop], Expr)] Type
deriving (Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show, forall x. Rep Expr x -> Expr
forall x. Expr -> Rep Expr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Expr x -> Expr
$cfrom :: forall x. Expr -> Rep Expr x
Generic, Expr -> ()
forall a. (a -> ()) -> NFData a
rnf :: Expr -> ()
$crnf :: Expr -> ()
NFData)
data Match = From Name Type Type Expr
| Let Decl
deriving (Int -> Match -> ShowS
[Match] -> ShowS
Match -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Match] -> ShowS
$cshowList :: [Match] -> ShowS
show :: Match -> String
$cshow :: Match -> String
showsPrec :: Int -> Match -> ShowS
$cshowsPrec :: Int -> Match -> ShowS
Show, forall x. Rep Match x -> Match
forall x. Match -> Rep Match x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Match x -> Match
$cfrom :: forall x. Match -> Rep Match x
Generic, Match -> ()
forall a. (a -> ()) -> NFData a
rnf :: Match -> ()
$crnf :: Match -> ()
NFData)
data DeclGroup = Recursive [Decl]
| NonRecursive Decl
deriving (Int -> DeclGroup -> ShowS
[DeclGroup] -> ShowS
DeclGroup -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeclGroup] -> ShowS
$cshowList :: [DeclGroup] -> ShowS
show :: DeclGroup -> String
$cshow :: DeclGroup -> String
showsPrec :: Int -> DeclGroup -> ShowS
$cshowsPrec :: Int -> DeclGroup -> ShowS
Show, forall x. Rep DeclGroup x -> DeclGroup
forall x. DeclGroup -> Rep DeclGroup x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DeclGroup x -> DeclGroup
$cfrom :: forall x. DeclGroup -> Rep DeclGroup x
Generic, DeclGroup -> ()
forall a. (a -> ()) -> NFData a
rnf :: DeclGroup -> ()
$crnf :: DeclGroup -> ()
NFData)
groupDecls :: DeclGroup -> [Decl]
groupDecls :: DeclGroup -> [Decl]
groupDecls DeclGroup
dg = case DeclGroup
dg of
Recursive [Decl]
ds -> [Decl]
ds
NonRecursive Decl
d -> [Decl
d]
data Decl = Decl { Decl -> Name
dName :: !Name
, Decl -> Schema
dSignature :: Schema
, Decl -> DeclDef
dDefinition :: DeclDef
, Decl -> [Pragma]
dPragmas :: [Pragma]
, Decl -> Bool
dInfix :: !Bool
, Decl -> Maybe Fixity
dFixity :: Maybe Fixity
, Decl -> Maybe Text
dDoc :: Maybe Text
} deriving (forall x. Rep Decl x -> Decl
forall x. Decl -> Rep Decl x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Decl x -> Decl
$cfrom :: forall x. Decl -> Rep Decl x
Generic, Decl -> ()
forall a. (a -> ()) -> NFData a
rnf :: Decl -> ()
$crnf :: Decl -> ()
NFData, Int -> Decl -> ShowS
[Decl] -> ShowS
Decl -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Decl] -> ShowS
$cshowList :: [Decl] -> ShowS
show :: Decl -> String
$cshow :: Decl -> String
showsPrec :: Int -> Decl -> ShowS
$cshowsPrec :: Int -> Decl -> ShowS
Show)
data DeclDef = DPrim
| DForeign FFIFunType
| DExpr Expr
deriving (Int -> DeclDef -> ShowS
[DeclDef] -> ShowS
DeclDef -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeclDef] -> ShowS
$cshowList :: [DeclDef] -> ShowS
show :: DeclDef -> String
$cshow :: DeclDef -> String
showsPrec :: Int -> DeclDef -> ShowS
$cshowsPrec :: Int -> DeclDef -> ShowS
Show, forall x. Rep DeclDef x -> DeclDef
forall x. DeclDef -> Rep DeclDef x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DeclDef x -> DeclDef
$cfrom :: forall x. DeclDef -> Rep DeclDef x
Generic, DeclDef -> ()
forall a. (a -> ()) -> NFData a
rnf :: DeclDef -> ()
$crnf :: DeclDef -> ()
NFData)
ePrim :: PrimMap -> PrimIdent -> Expr
ePrim :: PrimMap -> PrimIdent -> Expr
ePrim PrimMap
pm PrimIdent
n = Name -> Expr
EVar (PrimIdent -> PrimMap -> Name
lookupPrimDecl PrimIdent
n PrimMap
pm)
eError :: PrimMap -> Type -> String -> Expr
eError :: PrimMap -> Prop -> String -> Expr
eError PrimMap
prims Prop
t String
str =
Expr -> Expr -> Expr
EApp (Expr -> Prop -> Expr
ETApp (Expr -> Prop -> Expr
ETApp (PrimMap -> PrimIdent -> Expr
ePrim PrimMap
prims (Text -> PrimIdent
prelPrim Text
"error")) Prop
t)
(forall a. Integral a => a -> Prop
tNum (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str))) (PrimMap -> String -> Expr
eString PrimMap
prims String
str)
eString :: PrimMap -> String -> Expr
eString :: PrimMap -> String -> Expr
eString PrimMap
prims String
str = [Expr] -> Prop -> Expr
EList (forall a b. (a -> b) -> [a] -> [b]
map (PrimMap -> Char -> Expr
eChar PrimMap
prims) String
str) Prop
tChar
eChar :: PrimMap -> Char -> Expr
eChar :: PrimMap -> Char -> Expr
eChar PrimMap
prims Char
c = Expr -> Prop -> Expr
ETApp (Expr -> Prop -> Expr
ETApp (PrimMap -> PrimIdent -> Expr
ePrim PrimMap
prims (Text -> PrimIdent
prelPrim Text
"number")) (forall a. Integral a => a -> Prop
tNum Int
v)) (Prop -> Prop
tWord (forall a. Integral a => a -> Prop
tNum Int
w))
where v :: Int
v = forall a. Enum a => a -> Int
fromEnum Char
c
w :: Int
w = Int
8 :: Int
instance PP TCTopEntity where
ppPrec :: Int -> TCTopEntity -> Doc
ppPrec Int
_ TCTopEntity
te =
case TCTopEntity
te of
TCTopModule ModuleG ModName
m -> forall a. PP a => a -> Doc
pp ModuleG ModName
m
TCTopSignature ModName
x ModParamNames
p ->
(Doc
"interface" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp ModName
x Doc -> Doc -> Doc
<+> Doc
"where") Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 (forall a. PP a => a -> Doc
pp ModParamNames
p)
instance PP (WithNames Expr) where
ppPrec :: Int -> WithNames Expr -> Doc
ppPrec Int
prec (WithNames Expr
expr NameMap
nm) =
case Expr
expr of
ELocated Range
_ Expr
t -> forall {a}. PP (WithNames a) => Int -> a -> Doc
ppWP Int
prec Expr
t
EList [] Prop
t -> Bool -> Doc -> Doc
optParens (Int
prec forall a. Ord a => a -> a -> Bool
> Int
0)
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"[]" Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> forall {a}. PP (WithNames a) => Int -> a -> Doc
ppWP Int
prec Prop
t
EList [Expr]
es Prop
_ -> [Doc] -> Doc
ppList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. PP (WithNames a) => a -> Doc
ppW [Expr]
es
ETuple [Expr]
es -> [Doc] -> Doc
ppTuple forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. PP (WithNames a) => a -> Doc
ppW [Expr]
es
ERec RecordMap Ident Expr
fs -> [Doc] -> Doc
ppRecord
[ forall a. PP a => a -> Doc
pp Ident
f Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> forall {a}. PP (WithNames a) => a -> Doc
ppW Expr
e | (Ident
f,Expr
e) <- forall a b. (Show a, Ord a) => RecordMap a b -> [(a, b)]
displayFields RecordMap Ident Expr
fs ]
ESel Expr
e Selector
sel -> forall {a}. PP (WithNames a) => Int -> a -> Doc
ppWP Int
4 Expr
e Doc -> Doc -> Doc
<.> String -> Doc
text String
"." Doc -> Doc -> Doc
<.> forall a. PP a => a -> Doc
pp Selector
sel
ESet Prop
_ty Expr
e Selector
sel Expr
v -> Doc -> Doc
braces (forall a. PP a => a -> Doc
pp Expr
e Doc -> Doc -> Doc
<+> Doc
"|" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Selector
sel Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Expr
v)
EIf Expr
e1 Expr
e2 Expr
e3 -> Bool -> Doc -> Doc
optParens (Int
prec forall a. Ord a => a -> a -> Bool
> Int
0)
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [ String -> Doc
text String
"if" Doc -> Doc -> Doc
<+> forall {a}. PP (WithNames a) => a -> Doc
ppW Expr
e1
, String -> Doc
text String
"then" Doc -> Doc -> Doc
<+> forall {a}. PP (WithNames a) => a -> Doc
ppW Expr
e2
, String -> Doc
text String
"else" Doc -> Doc -> Doc
<+> forall {a}. PP (WithNames a) => a -> Doc
ppW Expr
e3 ]
EComp Prop
_ Prop
_ Expr
e [[Match]]
mss -> let arm :: [a] -> Doc
arm [a]
ms = String -> Doc
text String
"|" Doc -> Doc -> Doc
<+> [Doc] -> Doc
commaSep (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. PP (WithNames a) => a -> Doc
ppW [a]
ms)
in Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ forall {a}. PP (WithNames a) => a -> Doc
ppW Expr
e Doc -> Doc -> Doc
<+> (Doc -> Doc
align ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. PP (WithNames a) => [a] -> Doc
arm [[Match]]
mss)))
EVar Name
x -> forall a. PPName a => a -> Doc
ppPrefixName Name
x
EAbs {} -> let ([(Name, Prop)]
xs,Expr
e) = forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile Expr -> Maybe ((Name, Prop), Expr)
splitAbs Expr
expr
in NameMap
-> Int -> [TParam] -> [Prop] -> [(Name, Prop)] -> Expr -> Doc
ppLam NameMap
nm Int
prec [] [] [(Name, Prop)]
xs Expr
e
EProofAbs {} -> let ([Prop]
ps,Expr
e1) = forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile Expr -> Maybe (Prop, Expr)
splitProofAbs Expr
expr
([(Name, Prop)]
xs,Expr
e2) = forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile Expr -> Maybe ((Name, Prop), Expr)
splitAbs Expr
e1
in NameMap
-> Int -> [TParam] -> [Prop] -> [(Name, Prop)] -> Expr -> Doc
ppLam NameMap
nm Int
prec [] [Prop]
ps [(Name, Prop)]
xs Expr
e2
ETAbs {} -> let ([TParam]
ts,Expr
e1) = forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile Expr -> Maybe (TParam, Expr)
splitTAbs Expr
expr
([Prop]
ps,Expr
e2) = forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile Expr -> Maybe (Prop, Expr)
splitProofAbs Expr
e1
([(Name, Prop)]
xs,Expr
e3) = forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile Expr -> Maybe ((Name, Prop), Expr)
splitAbs Expr
e2
in NameMap
-> Int -> [TParam] -> [Prop] -> [(Name, Prop)] -> Expr -> Doc
ppLam NameMap
nm Int
prec [TParam]
ts [Prop]
ps [(Name, Prop)]
xs Expr
e3
EApp (EApp (EVar Name
o) Expr
a) Expr
b
| Ident -> Bool
isInfixIdent (Name -> Ident
nameIdent Name
o) ->
forall a. PP a => Int -> a -> Doc
ppPrec Int
3 Expr
a Doc -> Doc -> Doc
<+> forall a. PPName a => a -> Doc
ppInfixName Name
o Doc -> Doc -> Doc
<+> forall a. PP a => Int -> a -> Doc
ppPrec Int
3 Expr
b
| Bool
otherwise ->
forall a. PPName a => a -> Doc
ppPrefixName Name
o Doc -> Doc -> Doc
<+> forall a. PP a => Int -> a -> Doc
ppPrec Int
3 Expr
a Doc -> Doc -> Doc
<+> forall a. PP a => Int -> a -> Doc
ppPrec Int
3 Expr
b
EApp Expr
e1 Expr
e2 -> Bool -> Doc -> Doc
optParens (Int
prec forall a. Ord a => a -> a -> Bool
> Int
3)
forall a b. (a -> b) -> a -> b
$ forall {a}. PP (WithNames a) => Int -> a -> Doc
ppWP Int
3 Expr
e1 Doc -> Doc -> Doc
<+> forall {a}. PP (WithNames a) => Int -> a -> Doc
ppWP Int
4 Expr
e2
EProofApp Expr
e -> Bool -> Doc -> Doc
optParens (Int
prec forall a. Ord a => a -> a -> Bool
> Int
3)
forall a b. (a -> b) -> a -> b
$ forall {a}. PP (WithNames a) => Int -> a -> Doc
ppWP Int
3 Expr
e Doc -> Doc -> Doc
<+> String -> Doc
text String
"<>"
ETApp Expr
e Prop
t -> Bool -> Doc -> Doc
optParens (Int
prec forall a. Ord a => a -> a -> Bool
> Int
3)
forall a b. (a -> b) -> a -> b
$ forall {a}. PP (WithNames a) => Int -> a -> Doc
ppWP Int
3 Expr
e Doc -> Doc -> Doc
<+> forall {a}. PP (WithNames a) => Int -> a -> Doc
ppWP Int
5 Prop
t
EWhere Expr
e [DeclGroup]
ds -> Bool -> Doc -> Doc
optParens (Int
prec forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ Doc -> Doc
align forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vsep forall a b. (a -> b) -> a -> b
$
[ forall {a}. PP (WithNames a) => a -> Doc
ppW Expr
e
, Doc -> Int -> Doc -> Doc
hang Doc
"where" Int
2 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. PP (WithNames a) => a -> Doc
ppW [DeclGroup]
ds))
]
EPropGuards [([Prop], Expr)]
guards Prop
_ ->
Doc -> Doc
parens (String -> Doc
text String
"propguards" Doc -> Doc -> Doc
<+> [Doc] -> Doc
vsep (forall {a} {a}.
(PP (WithNames a), PP (WithNames a)) =>
([a], a) -> Doc
ppGuard forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Prop], Expr)]
guards))
where ppGuard :: ([a], a) -> Doc
ppGuard ([a]
props, a
e) = Int -> Doc -> Doc
indent Int
1
forall a b. (a -> b) -> a -> b
$ Doc
pipe Doc -> Doc -> Doc
<+> [Doc] -> Doc
commaSep (forall {a}. PP (WithNames a) => a -> Doc
ppW forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
props)
Doc -> Doc -> Doc
<+> String -> Doc
text String
"=>" Doc -> Doc -> Doc
<+> forall {a}. PP (WithNames a) => a -> Doc
ppW a
e
where
ppW :: a -> Doc
ppW a
x = forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
nm a
x
ppWP :: Int -> a -> Doc
ppWP Int
x = forall a. PP (WithNames a) => NameMap -> Int -> a -> Doc
ppWithNamesPrec NameMap
nm Int
x
ppLam :: NameMap -> Int -> [TParam] -> [Prop] -> [(Name,Type)] -> Expr -> Doc
ppLam :: NameMap
-> Int -> [TParam] -> [Prop] -> [(Name, Prop)] -> Expr -> Doc
ppLam NameMap
nm Int
prec [] [] [] Expr
e = Int -> Doc -> Doc
nest Int
2 (forall a. PP (WithNames a) => NameMap -> Int -> a -> Doc
ppWithNamesPrec NameMap
nm Int
prec Expr
e)
ppLam NameMap
nm Int
prec [TParam]
ts [Prop]
ps [(Name, Prop)]
xs Expr
e =
Bool -> Doc -> Doc
optParens (Int
prec forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep
[ String -> Doc
text String
"\\" Doc -> Doc -> Doc
<.> [Doc] -> Doc
hsep ([Doc]
tsD forall a. [a] -> [a] -> [a]
++ [Doc]
psD forall a. [a] -> [a] -> [a]
++ [Doc]
xsD forall a. [a] -> [a] -> [a]
++ [String -> Doc
text String
"->"])
, forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
ns1 Expr
e
]
where
ns1 :: NameMap
ns1 = [TParam] -> NameMap -> NameMap
addTNames [TParam]
ts NameMap
nm
tsD :: [Doc]
tsD = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TParam]
ts then [] else [Doc -> Doc
braces forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commaSep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TParam -> Doc
ppT [TParam]
ts]
psD :: [Doc]
psD = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Prop]
ps then [] else [Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
commaSep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Prop -> Doc
ppP [Prop]
ps]
xsD :: [Doc]
xsD = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, Prop)]
xs then [] else [[Doc] -> Doc
sep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (PP a, PP (WithNames a)) => (a, a) -> Doc
ppArg [(Name, Prop)]
xs]
ppT :: TParam -> Doc
ppT = forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
ns1
ppP :: Prop -> Doc
ppP = forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
ns1
ppArg :: (a, a) -> Doc
ppArg (a
x,a
t) = Doc -> Doc
parens (forall a. PP a => a -> Doc
pp a
x Doc -> Doc -> Doc
<+> String -> Doc
text String
":" Doc -> Doc -> Doc
<+> forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
ns1 a
t)
splitWhile :: (a -> Maybe (b,a)) -> a -> ([b],a)
splitWhile :: forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile a -> Maybe (b, a)
f a
e = case a -> Maybe (b, a)
f a
e of
Maybe (b, a)
Nothing -> ([], a
e)
Just (b
x,a
e1) -> let ([b]
xs,a
e2) = forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile a -> Maybe (b, a)
f a
e1
in (b
xforall a. a -> [a] -> [a]
:[b]
xs,a
e2)
splitLoc :: Expr -> Maybe (Range, Expr)
splitLoc :: Expr -> Maybe (Range, Expr)
splitLoc Expr
expr =
case Expr
expr of
ELocated Range
r Expr
e -> forall a. a -> Maybe a
Just (Range
r,Expr
e)
Expr
_ -> forall a. Maybe a
Nothing
dropLocs :: Expr -> Expr
dropLocs :: Expr -> Expr
dropLocs = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile Expr -> Maybe (Range, Expr)
splitLoc
splitAbs :: Expr -> Maybe ((Name,Type), Expr)
splitAbs :: Expr -> Maybe ((Name, Prop), Expr)
splitAbs (Expr -> Expr
dropLocs -> EAbs Name
x Prop
t Expr
e) = forall a. a -> Maybe a
Just ((Name
x,Prop
t), Expr
e)
splitAbs Expr
_ = forall a. Maybe a
Nothing
splitApp :: Expr -> Maybe (Expr,Expr)
splitApp :: Expr -> Maybe (Expr, Expr)
splitApp (Expr -> Expr
dropLocs -> EApp Expr
f Expr
a) = forall a. a -> Maybe a
Just (Expr
a, Expr
f)
splitApp Expr
_ = forall a. Maybe a
Nothing
splitTAbs :: Expr -> Maybe (TParam, Expr)
splitTAbs :: Expr -> Maybe (TParam, Expr)
splitTAbs (Expr -> Expr
dropLocs -> ETAbs TParam
t Expr
e) = forall a. a -> Maybe a
Just (TParam
t, Expr
e)
splitTAbs Expr
_ = forall a. Maybe a
Nothing
splitProofAbs :: Expr -> Maybe (Prop, Expr)
splitProofAbs :: Expr -> Maybe (Prop, Expr)
splitProofAbs (Expr -> Expr
dropLocs -> EProofAbs Prop
p Expr
e) = forall a. a -> Maybe a
Just (Prop
p,Expr
e)
splitProofAbs Expr
_ = forall a. Maybe a
Nothing
splitTApp :: Expr -> Maybe (Type,Expr)
splitTApp :: Expr -> Maybe (Prop, Expr)
splitTApp (Expr -> Expr
dropLocs -> ETApp Expr
e Prop
t) = forall a. a -> Maybe a
Just (Prop
t, Expr
e)
splitTApp Expr
_ = forall a. Maybe a
Nothing
splitProofApp :: Expr -> Maybe ((), Expr)
splitProofApp :: Expr -> Maybe ((), Expr)
splitProofApp (Expr -> Expr
dropLocs -> EProofApp Expr
e) = forall a. a -> Maybe a
Just ((), Expr
e)
splitProofApp Expr
_ = forall a. Maybe a
Nothing
splitExprInst :: Expr -> (Expr, [Type], Int)
splitExprInst :: Expr -> (Expr, [Prop], Int)
splitExprInst Expr
e = (Expr
e2, forall a. [a] -> [a]
reverse [Prop]
ts, forall (t :: * -> *) a. Foldable t => t a -> Int
length [()]
ps)
where
([()]
ps,Expr
e1) = forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile Expr -> Maybe ((), Expr)
splitProofApp Expr
e
([Prop]
ts,Expr
e2) = forall a b. (a -> Maybe (b, a)) -> a -> ([b], a)
splitWhile Expr -> Maybe (Prop, Expr)
splitTApp Expr
e1
instance HasLoc Expr where
getLoc :: Expr -> Maybe Range
getLoc (ELocated Range
r Expr
_) = forall a. a -> Maybe a
Just Range
r
getLoc Expr
_ = forall a. Maybe a
Nothing
instance PP Expr where
ppPrec :: Int -> Expr -> Doc
ppPrec Int
n Expr
t = forall a. PP (WithNames a) => NameMap -> Int -> a -> Doc
ppWithNamesPrec forall a. IntMap a
IntMap.empty Int
n Expr
t
instance PP (WithNames Match) where
ppPrec :: Int -> WithNames Match -> Doc
ppPrec Int
_ (WithNames Match
mat NameMap
nm) =
case Match
mat of
From Name
x Prop
_ Prop
_ Expr
e -> forall a. PP a => a -> Doc
pp Name
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+> forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
nm Expr
e
Let Decl
d -> String -> Doc
text String
"let" Doc -> Doc -> Doc
<+> forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
nm Decl
d
instance PP Match where
ppPrec :: Int -> Match -> Doc
ppPrec = forall a. PP (WithNames a) => NameMap -> Int -> a -> Doc
ppWithNamesPrec forall a. IntMap a
IntMap.empty
instance PP (WithNames DeclGroup) where
ppPrec :: Int -> WithNames DeclGroup -> Doc
ppPrec Int
_ (WithNames DeclGroup
dg NameMap
nm) =
case DeclGroup
dg of
Recursive [Decl]
ds -> String -> Doc
text String
"/* Recursive */"
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
nm) [Decl]
ds)
Doc -> Doc -> Doc
$$ String -> Doc
text String
""
NonRecursive Decl
d -> String -> Doc
text String
"/* Not recursive */"
Doc -> Doc -> Doc
$$ forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
nm Decl
d
Doc -> Doc -> Doc
$$ String -> Doc
text String
""
instance PP DeclGroup where
ppPrec :: Int -> DeclGroup -> Doc
ppPrec = forall a. PP (WithNames a) => NameMap -> Int -> a -> Doc
ppWithNamesPrec forall a. IntMap a
IntMap.empty
instance PP (WithNames Decl) where
ppPrec :: Int -> WithNames Decl -> Doc
ppPrec Int
_ (WithNames Decl { Bool
[Pragma]
Maybe Text
Maybe Fixity
Name
Schema
DeclDef
dDoc :: Maybe Text
dFixity :: Maybe Fixity
dInfix :: Bool
dPragmas :: [Pragma]
dDefinition :: DeclDef
dSignature :: Schema
dName :: Name
dDoc :: Decl -> Maybe Text
dFixity :: Decl -> Maybe Fixity
dInfix :: Decl -> Bool
dPragmas :: Decl -> [Pragma]
dSignature :: Decl -> Schema
dDefinition :: Decl -> DeclDef
dName :: Decl -> Name
.. } NameMap
nm) =
[Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$
[ forall a. PP a => a -> Doc
pp Name
dName Doc -> Doc -> Doc
<+> String -> Doc
text String
":" Doc -> Doc -> Doc
<+> forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
nm Schema
dSignature ]
forall a. [a] -> [a] -> [a]
++ (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pragma]
dPragmas
then []
else [String -> Doc
text String
"pragmas" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Name
dName Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp [Pragma]
dPragmas)])
forall a. [a] -> [a] -> [a]
++ [ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
sep [forall a. PP a => a -> Doc
pp Name
dName Doc -> Doc -> Doc
<+> String -> Doc
text String
"=", forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
nm DeclDef
dDefinition]) ]
instance PP (WithNames DeclDef) where
ppPrec :: Int -> WithNames DeclDef -> Doc
ppPrec Int
_ (WithNames DeclDef
DPrim NameMap
_) = String -> Doc
text String
"<primitive>"
ppPrec Int
_ (WithNames (DForeign FFIFunType
_) NameMap
_) = String -> Doc
text String
"<foreign>"
ppPrec Int
_ (WithNames (DExpr Expr
e) NameMap
nm) = forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
nm Expr
e
instance PP Decl where
ppPrec :: Int -> Decl -> Doc
ppPrec = forall a. PP (WithNames a) => NameMap -> Int -> a -> Doc
ppWithNamesPrec forall a. IntMap a
IntMap.empty
instance PP n => PP (ModuleG n) where
ppPrec :: Int -> ModuleG n -> Doc
ppPrec = forall a. PP (WithNames a) => NameMap -> Int -> a -> Doc
ppWithNamesPrec forall a. IntMap a
IntMap.empty
instance PP n => PP (WithNames (ModuleG n)) where
ppPrec :: Int -> WithNames (ModuleG n) -> Doc
ppPrec Int
_ (WithNames Module { n
[Located Prop]
[DeclGroup]
Maybe Text
FunctorParams
Map Name AbstractType
Map Name Newtype
Map Name TySyn
Map Name ModVParam
Map Name ModTParam
Map Name ModParamNames
Map Name (IfaceNames Name)
Map Name (ModuleG Name)
Set Name
ExportSpec Name
mSignatures :: Map Name ModParamNames
mSubmodules :: Map Name (IfaceNames Name)
mDecls :: [DeclGroup]
mPrimTypes :: Map Name AbstractType
mNewtypes :: Map Name Newtype
mTySyns :: Map Name TySyn
mNested :: Set Name
mFunctors :: Map Name (ModuleG Name)
mParams :: FunctorParams
mParamConstraints :: [Located Prop]
mParamFuns :: Map Name ModVParam
mParamTypes :: Map Name ModTParam
mExports :: ExportSpec Name
mDoc :: Maybe Text
mName :: n
mSignatures :: forall mname. ModuleG mname -> Map Name ModParamNames
mSubmodules :: forall mname. ModuleG mname -> Map Name (IfaceNames Name)
mDecls :: forall mname. ModuleG mname -> [DeclGroup]
mPrimTypes :: forall mname. ModuleG mname -> Map Name AbstractType
mNewtypes :: forall mname. ModuleG mname -> Map Name Newtype
mTySyns :: forall mname. ModuleG mname -> Map Name TySyn
mNested :: forall mname. ModuleG mname -> Set Name
mFunctors :: forall mname. ModuleG mname -> Map Name (ModuleG Name)
mParams :: forall mname. ModuleG mname -> FunctorParams
mParamConstraints :: forall mname. ModuleG mname -> [Located Prop]
mParamFuns :: forall mname. ModuleG mname -> Map Name ModVParam
mParamTypes :: forall mname. ModuleG mname -> Map Name ModTParam
mExports :: forall mname. ModuleG mname -> ExportSpec Name
mDoc :: forall mname. ModuleG mname -> Maybe Text
mName :: forall mname. ModuleG mname -> mname
.. } NameMap
nm) =
[Doc] -> Doc
vcat [ String -> Doc
text String
"module" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp n
mName
, [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. PP (WithNames a) => a -> Doc
pp' (forall k a. Map k a -> [a]
Map.elems Map Name TySyn
mTySyns))
, [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. PP (WithNames a) => a -> Doc
pp' [DeclGroup]
mDecls)
, [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp (forall k a. Map k a -> [a]
Map.elems Map Name (ModuleG Name)
mFunctors))
]
where mps :: [TParam]
mps = forall a b. (a -> b) -> [a] -> [b]
map ModTParam -> TParam
mtpParam (forall k a. Map k a -> [a]
Map.elems Map Name ModTParam
mParamTypes)
pp' :: PP (WithNames a) => a -> Doc
pp' :: forall {a}. PP (WithNames a) => a -> Doc
pp' = forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames ([TParam] -> NameMap -> NameMap
addTNames [TParam]
mps NameMap
nm)
instance PP (WithNames TCTopEntity) where
ppPrec :: Int -> WithNames TCTopEntity -> Doc
ppPrec Int
_ (WithNames TCTopEntity
ent NameMap
nm) =
case TCTopEntity
ent of
TCTopModule ModuleG ModName
m -> forall a. PP (WithNames a) => NameMap -> a -> Doc
ppWithNames NameMap
nm ModuleG ModName
m
TCTopSignature ModName
n ModParamNames
ps ->
Doc -> Int -> Doc -> Doc
hang (Doc
"interface module" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp ModName
n Doc -> Doc -> Doc
<+> Doc
"where") Int
2 (forall a. PP a => a -> Doc
pp ModParamNames
ps)