{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BlockArguments #-}
module Cryptol.Parser.NoPat (RemovePatterns(..),Error(..)) where
import Cryptol.Parser.AST
import Cryptol.Parser.Position(Range(..),emptyRange,start,at)
import Cryptol.Parser.Names (namesP)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.RecordMap
import MonadLib hiding (mapM)
import Data.Maybe(maybeToList)
import qualified Data.Map as Map
import Data.Text (Text)
import GHC.Generics (Generic)
import Control.DeepSeq
class RemovePatterns t where
removePatterns :: t -> (t, [Error])
instance RemovePatterns (Program PName) where
removePatterns :: Program PName -> (Program PName, [Error])
removePatterns Program PName
p = forall a. NoPatM a -> (a, [Error])
runNoPatM (Program PName -> NoPatM (Program PName)
noPatProg Program PName
p)
instance RemovePatterns (Expr PName) where
removePatterns :: Expr PName -> (Expr PName, [Error])
removePatterns Expr PName
e = forall a. NoPatM a -> (a, [Error])
runNoPatM (Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e)
instance RemovePatterns (ModuleG mname PName) where
removePatterns :: ModuleG mname PName -> (ModuleG mname PName, [Error])
removePatterns ModuleG mname PName
m = forall a. NoPatM a -> (a, [Error])
runNoPatM (forall mname. ModuleG mname PName -> NoPatM (ModuleG mname PName)
noPatModule ModuleG mname PName
m)
instance RemovePatterns [Decl PName] where
removePatterns :: [Decl PName] -> ([Decl PName], [Error])
removePatterns [Decl PName]
ds = forall a. NoPatM a -> (a, [Error])
runNoPatM ([Decl PName] -> NoPatM [Decl PName]
noPatDs [Decl PName]
ds)
instance RemovePatterns (NestedModule PName) where
removePatterns :: NestedModule PName -> (NestedModule PName, [Error])
removePatterns (NestedModule ModuleG PName PName
m) = (forall name. ModuleG name name -> NestedModule name
NestedModule ModuleG PName PName
m1,[Error]
errs)
where (ModuleG PName PName
m1,[Error]
errs) = forall t. RemovePatterns t => t -> (t, [Error])
removePatterns ModuleG PName PName
m
simpleBind :: Located PName -> Expr PName -> Bind PName
simpleBind :: Located PName -> Expr PName -> Bind PName
simpleBind Located PName
x Expr PName
e = Bind { bName :: Located PName
bName = Located PName
x, bParams :: [Pattern PName]
bParams = []
, bDef :: Located (BindDef PName)
bDef = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (forall a. Range -> a -> Located a
Located Range
emptyRange (forall name. Expr name -> BindDef name
DExpr Expr PName
e))
, bSignature :: Maybe (Schema PName)
bSignature = forall a. Maybe a
Nothing, bPragmas :: [Pragma]
bPragmas = []
, bMono :: Bool
bMono = Bool
True, bInfix :: Bool
bInfix = Bool
False, bFixity :: Maybe Fixity
bFixity = forall a. Maybe a
Nothing
, bDoc :: Maybe Text
bDoc = forall a. Maybe a
Nothing
, bExport :: ExportType
bExport = ExportType
Public
}
sel :: Pattern PName -> PName -> Selector -> Bind PName
sel :: Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
p PName
x Selector
s = let (Located PName
a,[Type PName]
ts) = Pattern PName -> (Located PName, [Type PName])
splitSimpleP Pattern PName
p
in Located PName -> Expr PName -> Bind PName
simpleBind Located PName
a (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall n. Expr n -> Type n -> Expr n
ETyped (forall n. Expr n -> Selector -> Expr n
ESel (forall n. n -> Expr n
EVar PName
x) Selector
s) [Type PName]
ts)
noPat :: Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat :: Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
pat =
case Pattern PName
pat of
PVar Located PName
x -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. Located n -> Pattern n
PVar Located PName
x, [])
Pattern PName
PWild ->
do PName
x <- NoPatM PName
newName
Range
r <- NoPatM Range
getRange
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Pattern n
pVar Range
r PName
x, [])
PTuple [Pattern PName]
ps ->
do ([Pattern PName]
as,[[Bind PName]]
dss) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat [Pattern PName]
ps
PName
x <- NoPatM PName
newName
Range
r <- NoPatM Range
getRange
let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern PName]
ps
ty :: Type n
ty = forall n. [Type n] -> Type n
TTuple (forall a. Int -> a -> [a]
replicate Int
len forall n. Type n
TWild)
getN :: Pattern PName -> Int -> Bind PName
getN Pattern PName
a Int
n = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a PName
x (Int -> Maybe Int -> Selector
TupleSel Int
n (forall a. a -> Maybe a
Just Int
len))
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x forall n. Type n
ty, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PName -> Int -> Bind PName
getN [Pattern PName]
as [Int
0..] forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bind PName]]
dss)
PList [] ->
do PName
x <- NoPatM PName
newName
Range
r <- NoPatM Range
getRange
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x (forall n. Type n -> Type n -> Type n
TSeq (forall n. Integer -> Type n
TNum Integer
0) forall n. Type n
TWild), [])
PList [Pattern PName]
ps ->
do ([Pattern PName]
as,[[Bind PName]]
dss) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat [Pattern PName]
ps
PName
x <- NoPatM PName
newName
Range
r <- NoPatM Range
getRange
let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern PName]
ps
ty :: Type n
ty = forall n. Type n -> Type n -> Type n
TSeq (forall n. Integer -> Type n
TNum (forall a. Integral a => a -> Integer
toInteger Int
len)) forall n. Type n
TWild
getN :: Pattern PName -> Int -> Bind PName
getN Pattern PName
a Int
n = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a PName
x (Int -> Maybe Int -> Selector
ListSel Int
n (forall a. a -> Maybe a
Just Int
len))
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x forall n. Type n
ty, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PName -> Int -> Bind PName
getN [Pattern PName]
as [Int
0..] forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bind PName]]
dss)
PRecord Rec (Pattern PName)
fs ->
do let ([Ident]
shape, [(Range, Pattern PName)]
els) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. RecordMap a b -> [(a, b)]
canonicalFields Rec (Pattern PName)
fs)
([Pattern PName]
as,[[Bind PName]]
dss) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Range, Pattern PName)]
els
PName
x <- NoPatM PName
newName
Range
r <- NoPatM Range
getRange
let ty :: Type n
ty = forall n. Rec (Type n) -> Type n
TRecord (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Range
rng,Pattern PName
_) -> (Range
rng,forall n. Type n
TWild)) Rec (Pattern PName)
fs)
getN :: Pattern PName -> Ident -> Bind PName
getN Pattern PName
a Ident
n = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a PName
x (Ident -> Maybe [Ident] -> Selector
RecordSel Ident
n (forall a. a -> Maybe a
Just [Ident]
shape))
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x forall n. Type n
ty, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PName -> Ident -> Bind PName
getN [Pattern PName]
as [Ident]
shape forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bind PName]]
dss)
PTyped Pattern PName
p Type PName
t ->
do (Pattern PName
a,[Bind PName]
ds) <- Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p
forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. Pattern n -> Type n -> Pattern n
PTyped Pattern PName
a Type PName
t, [Bind PName]
ds)
PSplit Pattern PName
p1 Pattern PName
p2 ->
do (Pattern PName
a1,[Bind PName]
ds1) <- Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p1
(Pattern PName
a2,[Bind PName]
ds2) <- Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p2
PName
x <- NoPatM PName
newName
PName
tmp <- NoPatM PName
newName
Range
r <- NoPatM Range
getRange
let bTmp :: Bind PName
bTmp = Located PName -> Expr PName -> Bind PName
simpleBind (forall a. Range -> a -> Located a
Located Range
r PName
tmp) (forall n. Expr n -> Expr n
ESplit (forall n. n -> Expr n
EVar PName
x))
b1 :: Bind PName
b1 = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a1 PName
tmp (Int -> Maybe Int -> Selector
TupleSel Int
0 (forall a. a -> Maybe a
Just Int
2))
b2 :: Bind PName
b2 = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a2 PName
tmp (Int -> Maybe Int -> Selector
TupleSel Int
1 (forall a. a -> Maybe a
Just Int
2))
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Pattern n
pVar Range
r PName
x, Bind PName
bTmp forall a. a -> [a] -> [a]
: Bind PName
b1 forall a. a -> [a] -> [a]
: Bind PName
b2 forall a. a -> [a] -> [a]
: [Bind PName]
ds1 forall a. [a] -> [a] -> [a]
++ [Bind PName]
ds2)
PLocated Pattern PName
p Range
r1 -> forall a. Range -> NoPatM a -> NoPatM a
inRange Range
r1 (Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p)
where
pVar :: Range -> n -> Pattern n
pVar Range
r n
x = forall n. Located n -> Pattern n
PVar (forall a. Range -> a -> Located a
Located Range
r n
x)
pTy :: Range -> n -> Type n -> Pattern n
pTy Range
r n
x Type n
t = forall n. Pattern n -> Type n -> Pattern n
PTyped (forall n. Located n -> Pattern n
PVar (forall a. Range -> a -> Located a
Located Range
r n
x)) Type n
t
splitSimpleP :: Pattern PName -> (Located PName, [Type PName])
splitSimpleP :: Pattern PName -> (Located PName, [Type PName])
splitSimpleP (PVar Located PName
x) = (Located PName
x, [])
splitSimpleP (PTyped Pattern PName
p Type PName
t) = let (Located PName
x,[Type PName]
ts) = Pattern PName -> (Located PName, [Type PName])
splitSimpleP Pattern PName
p
in (Located PName
x, Type PName
tforall a. a -> [a] -> [a]
:[Type PName]
ts)
splitSimpleP Pattern PName
p = forall a. HasCallStack => String -> [String] -> a
panic String
"splitSimpleP"
[ String
"Non-simple pattern", forall a. Show a => a -> String
show Pattern PName
p ]
noPatE :: Expr PName -> NoPatM (Expr PName)
noPatE :: Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
expr =
case Expr PName
expr of
EVar {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
ELit {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
EGenerate Expr PName
e -> forall n. Expr n -> Expr n
EGenerate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
ETuple [Expr PName]
es -> forall n. [Expr n] -> Expr n
ETuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr PName -> NoPatM (Expr PName)
noPatE [Expr PName]
es
ERecord Rec (Expr PName)
es -> forall n. Rec (Expr n) -> Expr n
ERecord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr PName -> NoPatM (Expr PName)
noPatE) Rec (Expr PName)
es
ESel Expr PName
e Selector
s -> forall n. Expr n -> Selector -> Expr n
ESel forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Selector
s
EUpd Maybe (Expr PName)
mb [UpdField PName]
fs -> forall n. Maybe (Expr n) -> [UpdField n] -> Expr n
EUpd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr PName -> NoPatM (Expr PName)
noPatE Maybe (Expr PName)
mb forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UpdField PName -> NoPatM (UpdField PName)
noPatUF [UpdField PName]
fs
EList [Expr PName]
es -> forall n. [Expr n] -> Expr n
EList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr PName -> NoPatM (Expr PName)
noPatE [Expr PName]
es
EFromTo {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
EFromToBy {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
EFromToDownBy {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
EFromToLessThan{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
EInfFrom Expr PName
e Maybe (Expr PName)
e' -> forall n. Expr n -> Maybe (Expr n) -> Expr n
EInfFrom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr PName -> NoPatM (Expr PName)
noPatE Maybe (Expr PName)
e'
EComp Expr PName
e [[Match PName]]
mss -> forall n. Expr n -> [[Match n]] -> Expr n
EComp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Match PName] -> NoPatM [Match PName]
noPatArm [[Match PName]]
mss
EApp Expr PName
e1 Expr PName
e2 -> forall n. Expr n -> Expr n -> Expr n
EApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e2
EAppT Expr PName
e [TypeInst PName]
ts -> forall n. Expr n -> [TypeInst n] -> Expr n
EAppT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return [TypeInst PName]
ts
EIf Expr PName
e1 Expr PName
e2 Expr PName
e3 -> forall n. Expr n -> Expr n -> Expr n -> Expr n
EIf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e3
EWhere Expr PName
e [Decl PName]
ds -> forall n. Expr n -> [Decl n] -> Expr n
EWhere forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Decl PName] -> NoPatM [Decl PName]
noPatDs [Decl PName]
ds
ETyped Expr PName
e Type PName
t -> forall n. Expr n -> Type n -> Expr n
ETyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Type PName
t
ETypeVal {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
EFun FunDesc PName
desc [Pattern PName]
ps Expr PName
e -> Maybe PName
-> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun (forall n. FunDesc n -> Maybe n
funDescrName FunDesc PName
desc) (forall n. FunDesc n -> Int
funDescrArgOffset FunDesc PName
desc) [Pattern PName]
ps Expr PName
e
ELocated Expr PName
e Range
r1 -> forall n. Expr n -> Range -> Expr n
ELocated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Range -> NoPatM a -> NoPatM a
inRange Range
r1 (Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Range
r1
ESplit Expr PName
e -> forall n. Expr n -> Expr n
ESplit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
EParens Expr PName
e -> forall n. Expr n -> Expr n
EParens forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
EInfix Expr PName
x Located PName
y Fixity
f Expr PName
z-> forall n. Expr n -> Located n -> Fixity -> Expr n -> Expr n
EInfix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Located PName
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Fixity
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
z
EPrefix PrefixOp
op Expr PName
e -> forall n. PrefixOp -> Expr n -> Expr n
EPrefix PrefixOp
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
noPatUF :: UpdField PName -> NoPatM (UpdField PName)
noPatUF :: UpdField PName -> NoPatM (UpdField PName)
noPatUF (UpdField UpdHow
h [Located Selector]
ls Expr PName
e) = forall n. UpdHow -> [Located Selector] -> Expr n -> UpdField n
UpdField UpdHow
h [Located Selector]
ls forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
noPatFun :: Maybe PName -> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun :: Maybe PName
-> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun Maybe PName
_ Int
_ [] Expr PName
e = Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
noPatFun Maybe PName
mnm Int
offset (Pattern PName
p:[Pattern PName]
ps) Expr PName
e =
do (Pattern PName
p',[Bind PName]
ds) <- Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p
Expr PName
e' <- Maybe PName
-> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun Maybe PName
mnm (Int
offsetforall a. Num a => a -> a -> a
+Int
1) [Pattern PName]
ps Expr PName
e
let body :: Expr PName
body = case [Bind PName]
ds of
[] -> Expr PName
e'
[Bind PName]
_ -> forall n. Expr n -> [Decl n] -> Expr n
EWhere Expr PName
e' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall name. Bind name -> Decl name
DBind (forall a. [a] -> [a]
reverse [Bind PName]
ds)
let desc :: FunDesc PName
desc = forall n. Maybe n -> Int -> FunDesc n
FunDesc Maybe PName
mnm Int
offset
forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun FunDesc PName
desc [Pattern PName
p'] Expr PName
body)
noPatArm :: [Match PName] -> NoPatM [Match PName]
noPatArm :: [Match PName] -> NoPatM [Match PName]
noPatArm [Match PName]
ms = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Match PName -> NoPatM [Match PName]
noPatM [Match PName]
ms
noPatM :: Match PName -> NoPatM [Match PName]
noPatM :: Match PName -> NoPatM [Match PName]
noPatM (Match Pattern PName
p Expr PName
e) =
do (Pattern PName
x,[Bind PName]
bs) <- Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p
Expr PName
e1 <- Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
forall (m :: * -> *) a. Monad m => a -> m a
return (forall name. Pattern name -> Expr name -> Match name
Match Pattern PName
x Expr PName
e1 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall name. Bind name -> Match name
MatchLet [Bind PName]
bs)
noPatM (MatchLet Bind PName
b) = (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. Bind name -> Match name
MatchLet) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bind PName -> NoPatM (Bind PName)
noMatchB Bind PName
b
noMatchB :: Bind PName -> NoPatM (Bind PName)
noMatchB :: Bind PName -> NoPatM (Bind PName)
noMatchB Bind PName
b =
case forall a. Located a -> a
thing (forall name. Bind name -> Located (BindDef name)
bDef Bind PName
b) of
BindDef PName
DPrim | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall name. Bind name -> [Pattern name]
bParams Bind PName
b) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bind PName
b
| Bool
otherwise -> forall a. HasCallStack => String -> [String] -> a
panic String
"NoPat" [ String
"noMatchB: primitive with params"
, forall a. Show a => a -> String
show Bind PName
b ]
BindDef PName
DForeign
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall name. Bind name -> [Pattern name]
bParams Bind PName
b) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bind PName
b
| Bool
otherwise -> forall a. HasCallStack => String -> [String] -> a
panic String
"NoPat" [ String
"noMatchB: foreign with params"
, forall a. Show a => a -> String
show Bind PName
b ]
DExpr Expr PName
e ->
do Expr PName
e' <- Maybe PName
-> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing (forall name. Bind name -> Located name
bName Bind PName
b))) Int
0 (forall name. Bind name -> [Pattern name]
bParams Bind PName
b) Expr PName
e
forall (m :: * -> *) a. Monad m => a -> m a
return Bind PName
b { bParams :: [Pattern PName]
bParams = [], bDef :: Located (BindDef PName)
bDef = forall name. Expr name -> BindDef name
DExpr Expr PName
e' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall name. Bind name -> Located (BindDef name)
bDef Bind PName
b }
DPropGuards [PropGuardCase PName]
guards ->
do let nm :: PName
nm = forall a. Located a -> a
thing (forall name. Bind name -> Located name
bName Bind PName
b)
ps :: [Pattern PName]
ps = forall name. Bind name -> [Pattern name]
bParams Bind PName
b
[PropGuardCase PName]
gs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PName
-> [Pattern PName]
-> PropGuardCase PName
-> NoPatM (PropGuardCase PName)
noPatPropGuardCase PName
nm [Pattern PName]
ps) [PropGuardCase PName]
guards
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bind PName
b { bParams :: [Pattern PName]
bParams = [], bDef :: Located (BindDef PName)
bDef = forall name. [PropGuardCase name] -> BindDef name
DPropGuards [PropGuardCase PName]
gs forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall name. Bind name -> Located (BindDef name)
bDef Bind PName
b }
noPatPropGuardCase ::
PName ->
[Pattern PName] ->
PropGuardCase PName -> NoPatM (PropGuardCase PName)
noPatPropGuardCase :: PName
-> [Pattern PName]
-> PropGuardCase PName
-> NoPatM (PropGuardCase PName)
noPatPropGuardCase PName
f [Pattern PName]
xs PropGuardCase PName
pc =
do Expr PName
e <- Maybe PName
-> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun (forall a. a -> Maybe a
Just PName
f) Int
0 [Pattern PName]
xs (forall name. PropGuardCase name -> Expr name
pgcExpr PropGuardCase PName
pc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PropGuardCase PName
pc { pgcExpr :: Expr PName
pgcExpr = Expr PName
e }
noMatchD :: Decl PName -> NoPatM [Decl PName]
noMatchD :: Decl PName -> NoPatM [Decl PName]
noMatchD Decl PName
decl =
case Decl PName
decl of
DSignature {} -> forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
DPragma {} -> forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
DFixity{} -> forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
DBind Bind PName
b -> do Bind PName
b1 <- Bind PName -> NoPatM (Bind PName)
noMatchB Bind PName
b
forall (m :: * -> *) a. Monad m => a -> m a
return [forall name. Bind name -> Decl name
DBind Bind PName
b1]
DRec {} -> forall a. HasCallStack => String -> [String] -> a
panic String
"noMatchD" [ String
"DRec" ]
DPatBind Pattern PName
p Expr PName
e -> do (Pattern PName
p',[Bind PName]
bs) <- Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p
let (Located PName
x,[Type PName]
ts) = Pattern PName -> (Located PName, [Type PName])
splitSimpleP Pattern PName
p'
Expr PName
e1 <- Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
let e2 :: Expr PName
e2 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall n. Expr n -> Type n -> Expr n
ETyped Expr PName
e1 [Type PName]
ts
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall name. Bind name -> Decl name
DBind Bind { bName :: Located PName
bName = Located PName
x
, bParams :: [Pattern PName]
bParams = []
, bDef :: Located (BindDef PName)
bDef = forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (forall a. Range -> a -> Located a
Located Range
emptyRange (forall name. Expr name -> BindDef name
DExpr Expr PName
e2))
, bSignature :: Maybe (Schema PName)
bSignature = forall a. Maybe a
Nothing
, bPragmas :: [Pragma]
bPragmas = []
, bMono :: Bool
bMono = Bool
False
, bInfix :: Bool
bInfix = Bool
False
, bFixity :: Maybe Fixity
bFixity = forall a. Maybe a
Nothing
, bDoc :: Maybe Text
bDoc = forall a. Maybe a
Nothing
, bExport :: ExportType
bExport = ExportType
Public
} forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall name. Bind name -> Decl name
DBind [Bind PName]
bs
DType {} -> forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
DProp {} -> forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
DLocated Decl PName
d Range
r1 -> do [Decl PName]
bs <- forall a. Range -> NoPatM a -> NoPatM a
inRange Range
r1 forall a b. (a -> b) -> a -> b
$ Decl PName -> NoPatM [Decl PName]
noMatchD Decl PName
d
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall name. Decl name -> Range -> Decl name
`DLocated` Range
r1) [Decl PName]
bs
noPatDs :: [Decl PName] -> NoPatM [Decl PName]
noPatDs :: [Decl PName] -> NoPatM [Decl PName]
noPatDs [Decl PName]
ds =
do [Decl PName]
ds1 <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PName -> NoPatM [Decl PName]
noMatchD [Decl PName]
ds
let fixes :: Map PName [Located Fixity]
fixes = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located Fixity])]
toFixity [Decl PName]
ds1
amap :: AnnotMap
amap = AnnotMap
{ annPragmas :: Map PName [Located Pragma]
annPragmas = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located Pragma])]
toPragma [Decl PName]
ds1
, annSigs :: Map PName [Located (Schema PName)]
annSigs = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located (Schema PName)])]
toSig [Decl PName]
ds1
, annValueFs :: Map PName [Located Fixity]
annValueFs = Map PName [Located Fixity]
fixes
, annTypeFs :: Map PName [Located Fixity]
annTypeFs = Map PName [Located Fixity]
fixes
, annDocs :: Map PName [Located Text]
annDocs = forall k a. Map k a
Map.empty
}
([Decl PName]
ds2, AnnotMap { Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annTypeFs :: Map PName [Located Fixity]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: AnnotMap -> Map PName [Located Text]
annTypeFs :: AnnotMap -> Map PName [Located Fixity]
annValueFs :: AnnotMap -> Map PName [Located Fixity]
annSigs :: AnnotMap -> Map PName [Located (Schema PName)]
annPragmas :: AnnotMap -> Map PName [Located Pragma]
.. }) <- forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT AnnotMap
amap (Annotates [Decl PName]
annotDs [Decl PName]
ds1)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Located Pragma]
annPragmas) forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located Pragma]
ps) ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located Pragma]
ps forall a b. (a -> b) -> a -> b
$ \Located Pragma
p -> Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ Located PName -> Pragma -> Error
PragmaNoBind (Located Pragma
p { thing :: PName
thing = PName
n }) (forall a. Located a -> a
thing Located Pragma
p)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Located (Schema PName)]
annSigs) forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located (Schema PName)]
ss) ->
do Maybe (Schema PName)
_ <- PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs PName
n [Located (Schema PName)]
ss
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located (Schema PName)]
ss forall a b. (a -> b) -> a -> b
$ \Located (Schema PName)
s -> Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ Located PName -> Schema PName -> Error
SignatureNoBind (Located (Schema PName)
s { thing :: PName
thing = PName
n })
(forall a. Located a -> a
thing Located (Schema PName)
s)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList (forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map PName [Located Fixity]
annValueFs Map PName [Located Fixity]
annTypeFs)) forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located Fixity]
fs) ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located Fixity]
fs forall a b. (a -> b) -> a -> b
$ \Located Fixity
f -> Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ Located PName -> Error
FixityNoBind Located Fixity
f { thing :: PName
thing = PName
n }
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName]
ds2
noPatTopDs :: [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs :: [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs [TopDecl PName]
tds =
do [TopDecl PName]
desugared <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TopDecl PName -> NoPatM [TopDecl PName]
desugar [TopDecl PName]
tds
let allDecls :: [Decl PName]
allDecls = forall a b. (a -> b) -> [a] -> [b]
map forall a. TopLevel a -> a
tlValue (forall {name}. [TopDecl name] -> [TopLevel (Decl name)]
decls [TopDecl PName]
desugared)
fixes :: Map PName [Located Fixity]
fixes = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located Fixity])]
toFixity [Decl PName]
allDecls
let ann :: AnnotMap
ann = AnnotMap
{ annPragmas :: Map PName [Located Pragma]
annPragmas = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located Pragma])]
toPragma [Decl PName]
allDecls
, annSigs :: Map PName [Located (Schema PName)]
annSigs = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located (Schema PName)])]
toSig [Decl PName]
allDecls
, annValueFs :: Map PName [Located Fixity]
annValueFs = Map PName [Located Fixity]
fixes
, annTypeFs :: Map PName [Located Fixity]
annTypeFs = Map PName [Located Fixity]
fixes
, annDocs :: Map PName [Located Text]
annDocs = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TopLevel (Decl PName) -> [(PName, [Located Text])]
toDocs forall a b. (a -> b) -> a -> b
$ forall {name}. [TopDecl name] -> [TopLevel (Decl name)]
decls [TopDecl PName]
tds
}
([TopDecl PName]
tds', AnnotMap { Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annTypeFs :: Map PName [Located Fixity]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: AnnotMap -> Map PName [Located Text]
annTypeFs :: AnnotMap -> Map PName [Located Fixity]
annValueFs :: AnnotMap -> Map PName [Located Fixity]
annSigs :: AnnotMap -> Map PName [Located (Schema PName)]
annPragmas :: AnnotMap -> Map PName [Located Pragma]
.. }) <- forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT AnnotMap
ann (Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
desugared)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Located Pragma]
annPragmas) forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located Pragma]
ps) ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located Pragma]
ps forall a b. (a -> b) -> a -> b
$ \Located Pragma
p -> Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ Located PName -> Pragma -> Error
PragmaNoBind (Located Pragma
p { thing :: PName
thing = PName
n }) (forall a. Located a -> a
thing Located Pragma
p)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Located (Schema PName)]
annSigs) forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located (Schema PName)]
ss) ->
do Maybe (Schema PName)
_ <- PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs PName
n [Located (Schema PName)]
ss
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located (Schema PName)]
ss forall a b. (a -> b) -> a -> b
$ \Located (Schema PName)
s -> Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ Located PName -> Schema PName -> Error
SignatureNoBind (Located (Schema PName)
s { thing :: PName
thing = PName
n })
(forall a. Located a -> a
thing Located (Schema PName)
s)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList (forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map PName [Located Fixity]
annValueFs Map PName [Located Fixity]
annTypeFs)) forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located Fixity]
fs) ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located Fixity]
fs forall a b. (a -> b) -> a -> b
$ \Located Fixity
f -> Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ Located PName -> Error
FixityNoBind Located Fixity
f { thing :: PName
thing = PName
n }
forall (m :: * -> *) a. Monad m => a -> m a
return [TopDecl PName]
tds'
where
decls :: [TopDecl name] -> [TopLevel (Decl name)]
decls [TopDecl name]
xs = [ TopLevel (Decl name)
d | Decl TopLevel (Decl name)
d <- [TopDecl name]
xs ]
desugar :: TopDecl PName -> NoPatM [TopDecl PName]
desugar TopDecl PName
d =
case TopDecl PName
d of
Decl TopLevel (Decl PName)
tl -> do [Decl PName]
ds <- Decl PName -> NoPatM [Decl PName]
noMatchD (forall a. TopLevel a -> a
tlValue TopLevel (Decl PName)
tl)
forall (m :: * -> *) a. Monad m => a -> m a
return [ forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel (Decl PName)
tl { tlValue :: Decl PName
tlValue = Decl PName
d1 } | Decl PName
d1 <- [Decl PName]
ds ]
TopDecl PName
x -> forall (m :: * -> *) a. Monad m => a -> m a
return [TopDecl PName
x]
noPatProg :: Program PName -> NoPatM (Program PName)
noPatProg :: Program PName -> NoPatM (Program PName)
noPatProg (Program [TopDecl PName]
topDs) = forall name. [TopDecl name] -> Program name
Program forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs [TopDecl PName]
topDs
noPatModule :: ModuleG mname PName -> NoPatM (ModuleG mname PName)
noPatModule :: forall mname. ModuleG mname PName -> NoPatM (ModuleG mname PName)
noPatModule ModuleG mname PName
m =
do ModuleDefinition PName
def <-
case forall mname name. ModuleG mname name -> ModuleDefinition name
mDef ModuleG mname PName
m of
NormalModule [TopDecl PName]
ds -> forall name. [TopDecl name] -> ModuleDefinition name
NormalModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs [TopDecl PName]
ds
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as ModuleInstance PName
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as ModuleInstance PName
i)
InterfaceModule Signature PName
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleG mname PName
m { mDef :: ModuleDefinition PName
mDef = ModuleDefinition PName
def }
data AnnotMap = AnnotMap
{ AnnotMap -> Map PName [Located Pragma]
annPragmas :: Map.Map PName [Located Pragma ]
, AnnotMap -> Map PName [Located (Schema PName)]
annSigs :: Map.Map PName [Located (Schema PName)]
, AnnotMap -> Map PName [Located Fixity]
annValueFs :: Map.Map PName [Located Fixity ]
, AnnotMap -> Map PName [Located Fixity]
annTypeFs :: Map.Map PName [Located Fixity ]
, AnnotMap -> Map PName [Located Text]
annDocs :: Map.Map PName [Located Text ]
}
type Annotates a = a -> StateT AnnotMap NoPatM a
annotTopDs :: Annotates [TopDecl PName]
annotTopDs :: Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
tds =
case [TopDecl PName]
tds of
TopDecl PName
d : [TopDecl PName]
ds ->
case TopDecl PName
d of
Decl TopLevel (Decl PName)
d1 ->
do Either () (Decl PName)
ignore <- forall i (m :: * -> *) a. ExceptionT i m a -> m (Either i a)
runExceptionT (Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD (forall a. TopLevel a -> a
tlValue TopLevel (Decl PName)
d1))
case Either () (Decl PName)
ignore of
Left ()
_ -> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
Right Decl PName
d2 -> (forall name. TopLevel (Decl name) -> TopDecl name
Decl (TopLevel (Decl PName)
d1 { tlValue :: Decl PName
tlValue = Decl PName
d2 }) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
DPrimType TopLevel (PrimType PName)
tl ->
do PrimType PName
pt <- Annotates (PrimType PName)
annotPrimType (forall a. TopLevel a -> a
tlValue TopLevel (PrimType PName)
tl)
let d1 :: TopDecl PName
d1 = forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel (PrimType PName)
tl { tlValue :: PrimType PName
tlValue = PrimType PName
pt }
(TopDecl PName
d1 forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
DParamDecl {} -> (TopDecl PName
d forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
DInterfaceConstraint {} -> (TopDecl PName
d forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
TDNewtype {} -> (TopDecl PName
d forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
Include {} -> (TopDecl PName
d forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
DModule TopLevel (NestedModule PName)
m ->
case forall t. RemovePatterns t => t -> (t, [Error])
removePatterns (forall a. TopLevel a -> a
tlValue TopLevel (NestedModule PName)
m) of
(NestedModule PName
m1,[Error]
errs) -> do forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Error -> NoPatM ()
recordError [Error]
errs)
(forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel (NestedModule PName)
m { tlValue :: NestedModule PName
tlValue = NestedModule PName
m1 } forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
DImport {} -> (TopDecl PName
d forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
DModParam {} -> (TopDecl PName
d forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return []
annotDs :: Annotates [Decl PName]
annotDs :: Annotates [Decl PName]
annotDs (Decl PName
d : [Decl PName]
ds) =
do Either () (Decl PName)
ignore <- forall i (m :: * -> *) a. ExceptionT i m a -> m (Either i a)
runExceptionT (Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD Decl PName
d)
case Either () (Decl PName)
ignore of
Left () -> Annotates [Decl PName]
annotDs [Decl PName]
ds
Right Decl PName
d1 -> (Decl PName
d1 forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [Decl PName]
annotDs [Decl PName]
ds
annotDs [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
annotD :: Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD :: Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD Decl PName
decl =
case Decl PName
decl of
DBind Bind PName
b -> forall name. Bind name -> Decl name
DBind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (Annotates (Bind PName)
annotB Bind PName
b)
DRec {} -> forall a. HasCallStack => String -> [String] -> a
panic String
"annotD" [ String
"DRec" ]
DSignature {} -> forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
DFixity{} -> forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
DPragma {} -> forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
DPatBind {} -> forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
DType TySyn PName
tysyn -> forall name. TySyn name -> Decl name
DType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (Annotates (TySyn PName)
annotTySyn TySyn PName
tysyn)
DProp PropSyn PName
propsyn -> forall name. PropSyn name -> Decl name
DProp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (Annotates (PropSyn PName)
annotPropSyn PropSyn PName
propsyn)
DLocated Decl PName
d Range
r -> (forall name. Decl name -> Range -> Decl name
`DLocated` Range
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD Decl PName
d
annotB :: Annotates (Bind PName)
annotB :: Annotates (Bind PName)
annotB Bind { Bool
[Pattern PName]
[Pragma]
Maybe Text
Maybe Fixity
Maybe (Schema PName)
Located PName
Located (BindDef PName)
ExportType
bExport :: ExportType
bDoc :: Maybe Text
bMono :: Bool
bPragmas :: [Pragma]
bFixity :: Maybe Fixity
bInfix :: Bool
bSignature :: Maybe (Schema PName)
bDef :: Located (BindDef PName)
bParams :: [Pattern PName]
bName :: Located PName
bExport :: forall name. Bind name -> ExportType
bDoc :: forall name. Bind name -> Maybe Text
bFixity :: forall name. Bind name -> Maybe Fixity
bInfix :: forall name. Bind name -> Bool
bMono :: forall name. Bind name -> Bool
bPragmas :: forall name. Bind name -> [Pragma]
bSignature :: forall name. Bind name -> Maybe (Schema name)
bDef :: forall name. Bind name -> Located (BindDef name)
bParams :: forall name. Bind name -> [Pattern name]
bName :: forall name. Bind name -> Located name
.. } =
do AnnotMap { Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annTypeFs :: Map PName [Located Fixity]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: AnnotMap -> Map PName [Located Text]
annTypeFs :: AnnotMap -> Map PName [Located Fixity]
annValueFs :: AnnotMap -> Map PName [Located Fixity]
annSigs :: AnnotMap -> Map PName [Located (Schema PName)]
annPragmas :: AnnotMap -> Map PName [Located Pragma]
.. } <- forall (m :: * -> *) i. StateM m i => m i
get
let name :: PName
name = forall a. Located a -> a
thing Located PName
bName
remove :: p -> p -> Maybe a
remove p
_ p
_ = forall a. Maybe a
Nothing
(Maybe [Located Pragma]
thisPs , Map PName [Located Pragma]
ps') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located Pragma]
annPragmas
(Maybe [Located (Schema PName)]
thisSigs , Map PName [Located (Schema PName)]
ss') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located (Schema PName)]
annSigs
(Maybe [Located Fixity]
thisFixes , Map PName [Located Fixity]
fs') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located Fixity]
annValueFs
(Maybe [Located Text]
thisDocs , Map PName [Located Text]
ds') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located Text]
annDocs
Maybe (Schema PName)
s <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs PName
name forall a b. (a -> b) -> a -> b
$ forall {a}. Maybe [a] -> [a]
jn Maybe [Located (Schema PName)]
thisSigs
Maybe Fixity
f <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs PName
name forall a b. (a -> b) -> a -> b
$ forall {a}. Maybe [a] -> [a]
jn Maybe [Located Fixity]
thisFixes
Maybe Text
d <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PName -> [Located Text] -> NoPatM (Maybe Text)
checkDocs PName
name forall a b. (a -> b) -> a -> b
$ forall {a}. Maybe [a] -> [a]
jn Maybe [Located Text]
thisDocs
forall (m :: * -> *) i. StateM m i => i -> m ()
set AnnotMap { annPragmas :: Map PName [Located Pragma]
annPragmas = Map PName [Located Pragma]
ps'
, annSigs :: Map PName [Located (Schema PName)]
annSigs = Map PName [Located (Schema PName)]
ss'
, annValueFs :: Map PName [Located Fixity]
annValueFs = Map PName [Located Fixity]
fs'
, annDocs :: Map PName [Located Text]
annDocs = Map PName [Located Text]
ds'
, Map PName [Located Fixity]
annTypeFs :: Map PName [Located Fixity]
annTypeFs :: Map PName [Located Fixity]
..
}
forall (m :: * -> *) a. Monad m => a -> m a
return Bind { bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
s
, bPragmas :: [Pragma]
bPragmas = forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> a
thing (forall {a}. Maybe [a] -> [a]
jn Maybe [Located Pragma]
thisPs) forall a. [a] -> [a] -> [a]
++ [Pragma]
bPragmas
, bFixity :: Maybe Fixity
bFixity = Maybe Fixity
f
, bDoc :: Maybe Text
bDoc = Maybe Text
d
, Bool
[Pattern PName]
Located PName
Located (BindDef PName)
ExportType
bExport :: ExportType
bMono :: Bool
bInfix :: Bool
bDef :: Located (BindDef PName)
bParams :: [Pattern PName]
bName :: Located PName
bExport :: ExportType
bInfix :: Bool
bMono :: Bool
bDef :: Located (BindDef PName)
bParams :: [Pattern PName]
bName :: Located PName
..
}
where jn :: Maybe [a] -> [a]
jn Maybe [a]
x = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. Maybe a -> [a]
maybeToList Maybe [a]
x)
annotTyThing :: PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing :: PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing PName
name =
do AnnotMap { Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annTypeFs :: Map PName [Located Fixity]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: AnnotMap -> Map PName [Located Text]
annTypeFs :: AnnotMap -> Map PName [Located Fixity]
annValueFs :: AnnotMap -> Map PName [Located Fixity]
annSigs :: AnnotMap -> Map PName [Located (Schema PName)]
annPragmas :: AnnotMap -> Map PName [Located Pragma]
.. } <- forall (m :: * -> *) i. StateM m i => m i
get
let remove :: p -> p -> Maybe a
remove p
_ p
_ = forall a. Maybe a
Nothing
(Maybe [Located Fixity]
thisFixes, Map PName [Located Fixity]
ts') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located Fixity]
annTypeFs
Maybe Fixity
f <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs PName
name forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe [Located Fixity]
thisFixes
forall (m :: * -> *) i. StateM m i => i -> m ()
set AnnotMap { annTypeFs :: Map PName [Located Fixity]
annTypeFs = Map PName [Located Fixity]
ts', Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
.. }
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Fixity
f
annotTySyn :: Annotates (TySyn PName)
annotTySyn :: Annotates (TySyn PName)
annotTySyn (TySyn Located PName
ln Maybe Fixity
_ [TParam PName]
params Type PName
rhs) =
do Maybe Fixity
f <- PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing (forall a. Located a -> a
thing Located PName
ln)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall n.
Located n -> Maybe Fixity -> [TParam n] -> Type n -> TySyn n
TySyn Located PName
ln Maybe Fixity
f [TParam PName]
params Type PName
rhs)
annotPropSyn :: Annotates (PropSyn PName)
annotPropSyn :: Annotates (PropSyn PName)
annotPropSyn (PropSyn Located PName
ln Maybe Fixity
_ [TParam PName]
params [Prop PName]
rhs) =
do Maybe Fixity
f <- PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing (forall a. Located a -> a
thing Located PName
ln)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall n.
Located n -> Maybe Fixity -> [TParam n] -> [Prop n] -> PropSyn n
PropSyn Located PName
ln Maybe Fixity
f [TParam PName]
params [Prop PName]
rhs)
annotPrimType :: Annotates (PrimType PName)
annotPrimType :: Annotates (PrimType PName)
annotPrimType PrimType PName
pt =
do Maybe Fixity
f <- PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing (forall a. Located a -> a
thing (forall name. PrimType name -> Located name
primTName PrimType PName
pt))
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimType PName
pt { primTFixity :: Maybe Fixity
primTFixity = Maybe Fixity
f }
checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs PName
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
checkSigs PName
_ [Located (Schema PName)
s] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located (Schema PName)
s))
checkSigs PName
f xs :: [Located (Schema PName)]
xs@(Located (Schema PName)
s : Located (Schema PName)
_ : [Located (Schema PName)]
_) = do Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ PName -> [Located (Schema PName)] -> Error
MultipleSignatures PName
f [Located (Schema PName)]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located (Schema PName)
s))
checkFixs :: PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs :: PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs PName
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
checkFixs PName
_ [Located Fixity
f] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located Fixity
f))
checkFixs PName
f fs :: [Located Fixity]
fs@(Located Fixity
x:[Located Fixity]
_) = do Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ PName -> [Range] -> Error
MultipleFixities PName
f forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> Range
srcRange [Located Fixity]
fs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located Fixity
x))
checkDocs :: PName -> [Located Text] -> NoPatM (Maybe Text)
checkDocs :: PName -> [Located Text] -> NoPatM (Maybe Text)
checkDocs PName
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
checkDocs PName
_ [Located Text
d] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located Text
d))
checkDocs PName
f ds :: [Located Text]
ds@(Located Text
d:[Located Text]
_) = do Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ PName -> [Range] -> Error
MultipleDocs PName
f (forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> Range
srcRange [Located Text]
ds)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located Text
d))
toSig :: Decl PName -> [(PName, [Located (Schema PName)])]
toSig :: Decl PName -> [(PName, [Located (Schema PName)])]
toSig (DLocated Decl PName
d Range
_) = Decl PName -> [(PName, [Located (Schema PName)])]
toSig Decl PName
d
toSig (DSignature [Located PName]
xs Schema PName
s) = [ (forall a. Located a -> a
thing Located PName
x,[forall a. Range -> a -> Located a
Located (forall a. Located a -> Range
srcRange Located PName
x) Schema PName
s]) | Located PName
x <- [Located PName]
xs ]
toSig Decl PName
_ = []
toPragma :: Decl PName -> [(PName, [Located Pragma])]
toPragma :: Decl PName -> [(PName, [Located Pragma])]
toPragma (DLocated Decl PName
d Range
_) = Decl PName -> [(PName, [Located Pragma])]
toPragma Decl PName
d
toPragma (DPragma [Located PName]
xs Pragma
s) = [ (forall a. Located a -> a
thing Located PName
x,[forall a. Range -> a -> Located a
Located (forall a. Located a -> Range
srcRange Located PName
x) Pragma
s]) | Located PName
x <- [Located PName]
xs ]
toPragma Decl PName
_ = []
toFixity :: Decl PName -> [(PName, [Located Fixity])]
toFixity :: Decl PName -> [(PName, [Located Fixity])]
toFixity (DFixity Fixity
f [Located PName]
ns) = [ (forall a. Located a -> a
thing Located PName
n, [forall a. Range -> a -> Located a
Located (forall a. Located a -> Range
srcRange Located PName
n) Fixity
f]) | Located PName
n <- [Located PName]
ns ]
toFixity Decl PName
_ = []
toDocs :: TopLevel (Decl PName) -> [(PName, [Located Text])]
toDocs :: TopLevel (Decl PName) -> [(PName, [Located Text])]
toDocs TopLevel { Maybe (Located Text)
ExportType
Decl PName
tlDoc :: forall a. TopLevel a -> Maybe (Located Text)
tlExport :: forall a. TopLevel a -> ExportType
tlValue :: Decl PName
tlDoc :: Maybe (Located Text)
tlExport :: ExportType
tlValue :: forall a. TopLevel a -> a
.. }
| Just Located Text
txt <- Maybe (Located Text)
tlDoc = forall {t} {name}. t -> Decl name -> [(name, [t])]
go Located Text
txt Decl PName
tlValue
| Bool
otherwise = []
where
go :: t -> Decl name -> [(name, [t])]
go t
txt Decl name
decl =
case Decl name
decl of
DSignature [Located name]
ns Schema name
_ -> [ (forall a. Located a -> a
thing Located name
n, [t
txt]) | Located name
n <- [Located name]
ns ]
DFixity Fixity
_ [Located name]
ns -> [ (forall a. Located a -> a
thing Located name
n, [t
txt]) | Located name
n <- [Located name]
ns ]
DBind Bind name
b -> [ (forall a. Located a -> a
thing (forall name. Bind name -> Located name
bName Bind name
b), [t
txt]) ]
DRec {} -> forall a. HasCallStack => String -> [String] -> a
panic String
"toDocs" [ String
"DRec" ]
DLocated Decl name
d Range
_ -> t -> Decl name -> [(name, [t])]
go t
txt Decl name
d
DPatBind Pattern name
p Expr name
_ -> [ (forall a. Located a -> a
thing Located name
n, [t
txt]) | Located name
n <- forall name. Pattern name -> [Located name]
namesP Pattern name
p ]
DPragma [Located name]
_ Pragma
_ -> []
DType TySyn name
_ -> []
DProp PropSyn name
_ -> []
newtype NoPatM a = M { forall a. NoPatM a -> ReaderT Range (StateT RW Id) a
unM :: ReaderT Range (StateT RW Id) a }
data RW = RW { RW -> Int
names :: !Int, RW -> [Error]
errors :: [Error] }
data Error = MultipleSignatures PName [Located (Schema PName)]
| SignatureNoBind (Located PName) (Schema PName)
| PragmaNoBind (Located PName) Pragma
| MultipleFixities PName [Range]
| FixityNoBind (Located PName)
| MultipleDocs PName [Range]
deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show,forall x. Rep Error x -> Error
forall x. Error -> Rep Error x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Error x -> Error
$cfrom :: forall x. Error -> Rep Error x
Generic, Error -> ()
forall a. (a -> ()) -> NFData a
rnf :: Error -> ()
$crnf :: Error -> ()
NFData)
instance Functor NoPatM where fmap :: forall a b. (a -> b) -> NoPatM a -> NoPatM b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative NoPatM where
pure :: forall a. a -> NoPatM a
pure a
x = forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
<*> :: forall a b. NoPatM (a -> b) -> NoPatM a -> NoPatM b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad NoPatM where
return :: forall a. a -> NoPatM a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
M ReaderT Range (StateT RW Id) a
x >>= :: forall a b. NoPatM a -> (a -> NoPatM b) -> NoPatM b
>>= a -> NoPatM b
k = forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M (ReaderT Range (StateT RW Id) a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. NoPatM a -> ReaderT Range (StateT RW Id) a
unM forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NoPatM b
k)
newName :: NoPatM PName
newName :: NoPatM PName
newName = forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets forall a b. (a -> b) -> a -> b
$ \RW
s -> let x :: Int
x = RW -> Int
names RW
s
in (Pass -> Int -> PName
NewName Pass
NoPat Int
x, RW
s { names :: Int
names = Int
x forall a. Num a => a -> a -> a
+ Int
1 })
recordError :: Error -> NoPatM ()
recordError :: Error -> NoPatM ()
recordError Error
e = forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. StateM m s => (s -> s) -> m ()
sets_ forall a b. (a -> b) -> a -> b
$ \RW
s -> RW
s { errors :: [Error]
errors = Error
e forall a. a -> [a] -> [a]
: RW -> [Error]
errors RW
s }
getRange :: NoPatM Range
getRange :: NoPatM Range
getRange = forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M forall (m :: * -> *) i. ReaderM m i => m i
ask
inRange :: Range -> NoPatM a -> NoPatM a
inRange :: forall a. Range -> NoPatM a -> NoPatM a
inRange Range
r NoPatM a
m = forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i a. RunReaderM m i => i -> m a -> m a
local Range
r forall a b. (a -> b) -> a -> b
$ forall a. NoPatM a -> ReaderT Range (StateT RW Id) a
unM NoPatM a
m
runNoPatM :: NoPatM a -> (a, [Error])
runNoPatM :: forall a. NoPatM a -> (a, [Error])
runNoPatM NoPatM a
m
= forall {a}. (a, RW) -> (a, [Error])
getErrs
forall a b. (a -> b) -> a -> b
$ forall a. Id a -> a
runId
forall a b. (a -> b) -> a -> b
$ forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT RW { names :: Int
names = Int
0, errors :: [Error]
errors = [] }
forall a b. (a -> b) -> a -> b
$ forall i (m :: * -> *) a. i -> ReaderT i m a -> m a
runReaderT (Position -> Position -> String -> Range
Range Position
start Position
start String
"")
forall a b. (a -> b) -> a -> b
$ forall a. NoPatM a -> ReaderT Range (StateT RW Id) a
unM NoPatM a
m
where getErrs :: (a, RW) -> (a, [Error])
getErrs (a
a,RW
rw) = (a
a, RW -> [Error]
errors RW
rw)
instance PP Error where
ppPrec :: Int -> Error -> Doc
ppPrec Int
_ Error
err =
case Error
err of
MultipleSignatures PName
x [Located (Schema PName)]
ss ->
String -> Doc
text String
"Multiple type signatures for" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (forall a. PP a => a -> Doc
pp PName
x)
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp [Located (Schema PName)]
ss))
SignatureNoBind Located PName
x Schema PName
s ->
String -> Doc
text String
"At" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp (forall a. Located a -> Range
srcRange Located PName
x) Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
<+>
String -> Doc
text String
"Type signature without a matching binding:"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 (forall a. PP a => a -> Doc
pp (forall a. Located a -> a
thing Located PName
x) Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Schema PName
s)
PragmaNoBind Located PName
x Pragma
s ->
String -> Doc
text String
"At" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp (forall a. Located a -> Range
srcRange Located PName
x) Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
<+>
String -> Doc
text String
"Pragma without a matching binding:"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 (forall a. PP a => a -> Doc
pp Pragma
s)
MultipleFixities PName
n [Range]
locs ->
String -> Doc
text String
"Multiple fixity declarations for" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (forall a. PP a => a -> Doc
pp PName
n)
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp [Range]
locs))
FixityNoBind Located PName
n ->
String -> Doc
text String
"At" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp (forall a. Located a -> Range
srcRange Located PName
n) Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
<+>
String -> Doc
text String
"Fixity declaration without a matching binding for:" Doc -> Doc -> Doc
<+>
forall a. PP a => a -> Doc
pp (forall a. Located a -> a
thing Located PName
n)
MultipleDocs PName
n [Range]
locs ->
String -> Doc
text String
"Multiple documentation blocks given for:" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp PName
n
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp [Range]
locs))