-- |
-- Module      :  Cryptol.Parser.NoPat
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable
--
-- The purpose of this module is to convert all patterns to variable
-- patterns.  It also eliminates pattern bindings by de-sugaring them
-- into `Bind`.  Furthermore, here we associate signatures and pragmas
-- with the names to which they belong.

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
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
  -- | Eliminate all patterns in a program.
  removePatterns :: t -> (t, [Error])

instance RemovePatterns (Program PName) where
  removePatterns :: Program PName -> (Program PName, [Error])
removePatterns Program PName
p = NoPatM (Program PName) -> (Program PName, [Error])
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 = NoPatM (Expr PName) -> (Expr PName, [Error])
forall a. NoPatM a -> (a, [Error])
runNoPatM (Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e)

instance RemovePatterns (Module PName) where
  removePatterns :: Module PName -> (Module PName, [Error])
removePatterns Module PName
m = NoPatM (Module PName) -> (Module PName, [Error])
forall a. NoPatM a -> (a, [Error])
runNoPatM (Module PName -> NoPatM (Module PName)
noPatModule Module PName
m)

instance RemovePatterns [Decl PName] where
  removePatterns :: [Decl PName] -> ([Decl PName], [Error])
removePatterns [Decl PName]
ds = NoPatM [Decl PName] -> ([Decl PName], [Error])
forall a. NoPatM a -> (a, [Error])
runNoPatM ([Decl PName] -> NoPatM [Decl PName]
noPatDs [Decl PName]
ds)

simpleBind :: Located PName -> Expr PName -> Bind PName
simpleBind :: Located PName -> Expr PName -> Bind PName
simpleBind Located PName
x Expr PName
e = Bind :: forall name.
Located name
-> [Pattern name]
-> Located (BindDef name)
-> Maybe (Schema name)
-> Bool
-> Maybe Fixity
-> [Pragma]
-> Bool
-> Maybe Text
-> Bind name
Bind { bName :: Located PName
bName = Located PName
x, bParams :: [Pattern PName]
bParams = []
                      , bDef :: Located (BindDef PName)
bDef = Expr PName -> Located (BindDef PName) -> Located (BindDef PName)
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located Range
emptyRange (Expr PName -> BindDef PName
forall name. Expr name -> BindDef name
DExpr Expr PName
e))
                      , bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
forall a. Maybe a
Nothing, bPragmas :: [Pragma]
bPragmas = []
                      , bMono :: Bool
bMono = Bool
True, bInfix :: Bool
bInfix = Bool
False, bFixity :: Maybe Fixity
bFixity = Maybe Fixity
forall a. Maybe a
Nothing
                      , bDoc :: Maybe Text
bDoc = Maybe Text
forall a. Maybe a
Nothing
                      }

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 ((Expr PName -> Type PName -> Expr PName)
-> Expr PName -> [Type PName] -> Expr PName
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr PName -> Type PName -> Expr PName
forall n. Expr n -> Type n -> Expr n
ETyped (Expr PName -> Selector -> Expr PName
forall n. Expr n -> Selector -> Expr n
ESel (PName -> Expr PName
forall n. n -> Expr n
EVar PName
x) Selector
s) [Type PName]
ts)

-- | Given a pattern, transform it into a simple pattern and a set of bindings.
-- Simple patterns may only contain variables and type annotations.

-- XXX: We can replace the types in the selectors with annotations on the bindings.
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 -> (Pattern PName, [Bind PName])
-> NoPatM (Pattern PName, [Bind PName])
forall (m :: * -> *) a. Monad m => a -> m a
return (Located PName -> Pattern PName
forall n. Located n -> Pattern n
PVar Located PName
x, [])

    Pattern PName
PWild ->
      do PName
x <- NoPatM PName
newName
         Range
r <- NoPatM Range
getRange
         (Pattern PName, [Bind PName])
-> NoPatM (Pattern PName, [Bind PName])
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> PName -> Pattern PName
forall n. Range -> n -> Pattern n
pVar Range
r PName
x, [])

    PTuple [Pattern PName]
ps ->
      do ([Pattern PName]
as,[[Bind PName]]
dss) <- [(Pattern PName, [Bind PName])]
-> ([Pattern PName], [[Bind PName]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pattern PName, [Bind PName])]
 -> ([Pattern PName], [[Bind PName]]))
-> NoPatM [(Pattern PName, [Bind PName])]
-> NoPatM ([Pattern PName], [[Bind PName]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Pattern PName -> NoPatM (Pattern PName, [Bind PName]))
-> [Pattern PName] -> NoPatM [(Pattern PName, [Bind PName])]
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      = [Pattern PName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern PName]
ps
             ty :: Type n
ty       = [Type n] -> Type n
forall n. [Type n] -> Type n
TTuple (Int -> Type n -> [Type n]
forall a. Int -> a -> [a]
replicate Int
len Type n
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
len))
         (Pattern PName, [Bind PName])
-> NoPatM (Pattern PName, [Bind PName])
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> PName -> Type PName -> Pattern PName
forall n. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x Type PName
forall n. Type n
ty, (Pattern PName -> Int -> Bind PName)
-> [Pattern PName] -> [Int] -> [Bind PName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PName -> Int -> Bind PName
getN [Pattern PName]
as [Int
0..] [Bind PName] -> [Bind PName] -> [Bind PName]
forall a. [a] -> [a] -> [a]
++ [[Bind PName]] -> [Bind PName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bind PName]]
dss)

    PList [] ->
      do PName
x <- NoPatM PName
newName
         Range
r <- NoPatM Range
getRange
         (Pattern PName, [Bind PName])
-> NoPatM (Pattern PName, [Bind PName])
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> PName -> Type PName -> Pattern PName
forall n. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x (Type PName -> Type PName -> Type PName
forall n. Type n -> Type n -> Type n
TSeq (Integer -> Type PName
forall n. Integer -> Type n
TNum Integer
0) Type PName
forall n. Type n
TWild), [])

    PList [Pattern PName]
ps ->
      do ([Pattern PName]
as,[[Bind PName]]
dss) <- [(Pattern PName, [Bind PName])]
-> ([Pattern PName], [[Bind PName]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pattern PName, [Bind PName])]
 -> ([Pattern PName], [[Bind PName]]))
-> NoPatM [(Pattern PName, [Bind PName])]
-> NoPatM ([Pattern PName], [[Bind PName]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Pattern PName -> NoPatM (Pattern PName, [Bind PName]))
-> [Pattern PName] -> NoPatM [(Pattern PName, [Bind PName])]
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      = [Pattern PName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern PName]
ps
             ty :: Type n
ty       = Type n -> Type n -> Type n
forall n. Type n -> Type n -> Type n
TSeq (Integer -> Type n
forall n. Integer -> Type n
TNum (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
len)) Type n
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
len))
         (Pattern PName, [Bind PName])
-> NoPatM (Pattern PName, [Bind PName])
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> PName -> Type PName -> Pattern PName
forall n. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x Type PName
forall n. Type n
ty, (Pattern PName -> Int -> Bind PName)
-> [Pattern PName] -> [Int] -> [Bind PName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PName -> Int -> Bind PName
getN [Pattern PName]
as [Int
0..] [Bind PName] -> [Bind PName] -> [Bind PName]
forall a. [a] -> [a] -> [a]
++ [[Bind PName]] -> [Bind PName]
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) = [(Ident, (Range, Pattern PName))]
-> ([Ident], [(Range, Pattern PName)])
forall a b. [(a, b)] -> ([a], [b])
unzip (Rec (Pattern PName) -> [(Ident, (Range, Pattern PName))]
forall a b. RecordMap a b -> [(a, b)]
canonicalFields Rec (Pattern PName)
fs)
         ([Pattern PName]
as,[[Bind PName]]
dss) <- [(Pattern PName, [Bind PName])]
-> ([Pattern PName], [[Bind PName]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pattern PName, [Bind PName])]
 -> ([Pattern PName], [[Bind PName]]))
-> NoPatM [(Pattern PName, [Bind PName])]
-> NoPatM ([Pattern PName], [[Bind PName]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((Range, Pattern PName) -> NoPatM (Pattern PName, [Bind PName]))
-> [(Range, Pattern PName)]
-> NoPatM [(Pattern PName, [Bind PName])]
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 -> NoPatM (Pattern PName, [Bind PName]))
-> ((Range, Pattern PName) -> Pattern PName)
-> (Range, Pattern PName)
-> NoPatM (Pattern PName, [Bind PName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range, Pattern PName) -> Pattern PName
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           = Rec (Type n) -> Type n
forall n. Rec (Type n) -> Type n
TRecord (((Range, Pattern PName) -> (Range, Type n))
-> Rec (Pattern PName) -> Rec (Type n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Range
rng,Pattern PName
_) -> (Range
rng,Type n
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 ([Ident] -> Maybe [Ident]
forall a. a -> Maybe a
Just [Ident]
shape))
         (Pattern PName, [Bind PName])
-> NoPatM (Pattern PName, [Bind PName])
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> PName -> Type PName -> Pattern PName
forall n. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x Type PName
forall n. Type n
ty, (Pattern PName -> Ident -> Bind PName)
-> [Pattern PName] -> [Ident] -> [Bind PName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PName -> Ident -> Bind PName
getN [Pattern PName]
as [Ident]
shape [Bind PName] -> [Bind PName] -> [Bind PName]
forall a. [a] -> [a] -> [a]
++ [[Bind PName]] -> [Bind PName]
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
         (Pattern PName, [Bind PName])
-> NoPatM (Pattern PName, [Bind PName])
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern PName -> Type PName -> Pattern PName
forall n. Pattern n -> Type n -> Pattern n
PTyped Pattern PName
a Type PName
t, [Bind PName]
ds)

    -- XXX: We can do more with type annotations here
    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 (Range -> PName -> Located PName
forall a. Range -> a -> Located a
Located Range
r PName
tmp) (Expr PName -> Expr PName
forall n. Expr n -> Expr n
ESplit (PName -> Expr PName
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 (Int -> Maybe Int
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2))
         (Pattern PName, [Bind PName])
-> NoPatM (Pattern PName, [Bind PName])
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> PName -> Pattern PName
forall n. Range -> n -> Pattern n
pVar Range
r PName
x, Bind PName
bTmp Bind PName -> [Bind PName] -> [Bind PName]
forall a. a -> [a] -> [a]
: Bind PName
b1 Bind PName -> [Bind PName] -> [Bind PName]
forall a. a -> [a] -> [a]
: Bind PName
b2 Bind PName -> [Bind PName] -> [Bind PName]
forall a. a -> [a] -> [a]
: [Bind PName]
ds1 [Bind PName] -> [Bind PName] -> [Bind PName]
forall a. [a] -> [a] -> [a]
++ [Bind PName]
ds2)

    PLocated Pattern PName
p Range
r1 -> Range
-> NoPatM (Pattern PName, [Bind PName])
-> NoPatM (Pattern PName, [Bind PName])
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   = Located n -> Pattern n
forall n. Located n -> Pattern n
PVar (Range -> n -> Located n
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 = Pattern n -> Type n -> Pattern n
forall n. Pattern n -> Type n -> Pattern n
PTyped (Located n -> Pattern n
forall n. Located n -> Pattern n
PVar (Range -> n -> Located n
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
tType PName -> [Type PName] -> [Type PName]
forall a. a -> [a] -> [a]
:[Type PName]
ts)
splitSimpleP Pattern PName
p            = String -> [String] -> (Located PName, [Type PName])
forall a. HasCallStack => String -> [String] -> a
panic String
"splitSimpleP"
                                  [ String
"Non-simple pattern", Pattern PName -> String
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 {}       -> Expr PName -> NoPatM (Expr PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    ELit {}       -> Expr PName -> NoPatM (Expr PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    ENeg Expr PName
e        -> Expr PName -> Expr PName
forall n. Expr n -> Expr n
ENeg    (Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
    EComplement Expr PName
e -> Expr PName -> Expr PName
forall n. Expr n -> Expr n
EComplement (Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
    EGenerate Expr PName
e   -> Expr PName -> Expr PName
forall n. Expr n -> Expr n
EGenerate (Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName)
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     -> [Expr PName] -> Expr PName
forall n. [Expr n] -> Expr n
ETuple  ([Expr PName] -> Expr PName)
-> NoPatM [Expr PName] -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr PName -> NoPatM (Expr PName))
-> [Expr PName] -> NoPatM [Expr PName]
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    -> Rec (Expr PName) -> Expr PName
forall n. Rec (Expr n) -> Expr n
ERecord (Rec (Expr PName) -> Expr PName)
-> NoPatM (Rec (Expr PName)) -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Range, Expr PName) -> NoPatM (Range, Expr PName))
-> Rec (Expr PName) -> NoPatM (Rec (Expr PName))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Expr PName -> NoPatM (Expr PName))
-> (Range, Expr PName) -> NoPatM (Range, Expr PName)
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      -> Expr PName -> Selector -> Expr PName
forall n. Expr n -> Selector -> Expr n
ESel    (Expr PName -> Selector -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Selector -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e NoPatM (Selector -> Expr PName)
-> NoPatM Selector -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Selector -> NoPatM Selector
forall (m :: * -> *) a. Monad m => a -> m a
return Selector
s
    EUpd Maybe (Expr PName)
mb [UpdField PName]
fs    -> Maybe (Expr PName) -> [UpdField PName] -> Expr PName
forall n. Maybe (Expr n) -> [UpdField n] -> Expr n
EUpd    (Maybe (Expr PName) -> [UpdField PName] -> Expr PName)
-> NoPatM (Maybe (Expr PName))
-> NoPatM ([UpdField PName] -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr PName -> NoPatM (Expr PName))
-> Maybe (Expr PName) -> NoPatM (Maybe (Expr PName))
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 NoPatM ([UpdField PName] -> Expr PName)
-> NoPatM [UpdField PName] -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (UpdField PName -> NoPatM (UpdField PName))
-> [UpdField PName] -> NoPatM [UpdField PName]
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      -> [Expr PName] -> Expr PName
forall n. [Expr n] -> Expr n
EList   ([Expr PName] -> Expr PName)
-> NoPatM [Expr PName] -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr PName -> NoPatM (Expr PName))
-> [Expr PName] -> NoPatM [Expr PName]
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 {}    -> Expr PName -> NoPatM (Expr PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    EInfFrom Expr PName
e Maybe (Expr PName)
e' -> Expr PName -> Maybe (Expr PName) -> Expr PName
forall n. Expr n -> Maybe (Expr n) -> Expr n
EInfFrom (Expr PName -> Maybe (Expr PName) -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Maybe (Expr PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e NoPatM (Maybe (Expr PName) -> Expr PName)
-> NoPatM (Maybe (Expr PName)) -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr PName -> NoPatM (Expr PName))
-> Maybe (Expr PName) -> NoPatM (Maybe (Expr PName))
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   -> Expr PName -> [[Match PName]] -> Expr PName
forall n. Expr n -> [[Match n]] -> Expr n
EComp  (Expr PName -> [[Match PName]] -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM ([[Match PName]] -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e NoPatM ([[Match PName]] -> Expr PName)
-> NoPatM [[Match PName]] -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Match PName] -> NoPatM [Match PName])
-> [[Match PName]] -> NoPatM [[Match PName]]
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    -> Expr PName -> Expr PName -> Expr PName
forall n. Expr n -> Expr n -> Expr n
EApp   (Expr PName -> Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e1 NoPatM (Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName)
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    -> Expr PName -> [TypeInst PName] -> Expr PName
forall n. Expr n -> [TypeInst n] -> Expr n
EAppT  (Expr PName -> [TypeInst PName] -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM ([TypeInst PName] -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e NoPatM ([TypeInst PName] -> Expr PName)
-> NoPatM [TypeInst PName] -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TypeInst PName] -> NoPatM [TypeInst PName]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeInst PName]
ts
    EIf Expr PName
e1 Expr PName
e2 Expr PName
e3  -> Expr PName -> Expr PName -> Expr PName -> Expr PName
forall n. Expr n -> Expr n -> Expr n -> Expr n
EIf    (Expr PName -> Expr PName -> Expr PName -> Expr PName)
-> NoPatM (Expr PName)
-> NoPatM (Expr PName -> Expr PName -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e1 NoPatM (Expr PName -> Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e2 NoPatM (Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName)
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   -> Expr PName -> [Decl PName] -> Expr PName
forall n. Expr n -> [Decl n] -> Expr n
EWhere (Expr PName -> [Decl PName] -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM ([Decl PName] -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e NoPatM ([Decl PName] -> Expr PName)
-> NoPatM [Decl PName] -> NoPatM (Expr PName)
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    -> Expr PName -> Type PName -> Expr PName
forall n. Expr n -> Type n -> Expr n
ETyped (Expr PName -> Type PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Type PName -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e NoPatM (Type PName -> Expr PName)
-> NoPatM (Type PName) -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type PName -> NoPatM (Type PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Type PName
t
    ETypeVal {}   -> Expr PName -> NoPatM (Expr PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    EFun [Pattern PName]
ps Expr PName
e     -> do ([Pattern PName]
ps1,Expr PName
e1) <- [Pattern PName]
-> Expr PName -> NoPatM ([Pattern PName], Expr PName)
noPatFun [Pattern PName]
ps Expr PName
e
                        Expr PName -> NoPatM (Expr PName)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pattern PName] -> Expr PName -> Expr PName
forall n. [Pattern n] -> Expr n -> Expr n
EFun [Pattern PName]
ps1 Expr PName
e1)
    ELocated Expr PName
e Range
r1 -> Expr PName -> Range -> Expr PName
forall n. Expr n -> Range -> Expr n
ELocated (Expr PName -> Range -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Range -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> NoPatM (Expr PName) -> NoPatM (Expr PName)
forall a. Range -> NoPatM a -> NoPatM a
inRange Range
r1 (Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e) NoPatM (Range -> Expr PName) -> NoPatM Range -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> NoPatM Range
forall (m :: * -> *) a. Monad m => a -> m a
return Range
r1

    ESplit Expr PName
e      -> Expr PName -> Expr PName
forall n. Expr n -> Expr n
ESplit  (Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName)
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     -> Expr PName -> Expr PName
forall n. Expr n -> Expr n
EParens (Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName)
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-> Expr PName -> Located PName -> Fixity -> Expr PName -> Expr PName
forall n. Expr n -> Located n -> Fixity -> Expr n -> Expr n
EInfix  (Expr PName -> Located PName -> Fixity -> Expr PName -> Expr PName)
-> NoPatM (Expr PName)
-> NoPatM (Located PName -> Fixity -> Expr PName -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
x NoPatM (Located PName -> Fixity -> Expr PName -> Expr PName)
-> NoPatM (Located PName)
-> NoPatM (Fixity -> Expr PName -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Located PName -> NoPatM (Located PName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Located PName
y NoPatM (Fixity -> Expr PName -> Expr PName)
-> NoPatM Fixity -> NoPatM (Expr PName -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Fixity -> NoPatM Fixity
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fixity
f NoPatM (Expr PName -> Expr PName)
-> NoPatM (Expr PName) -> NoPatM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
z


noPatUF :: UpdField PName -> NoPatM (UpdField PName)
noPatUF :: UpdField PName -> NoPatM (UpdField PName)
noPatUF (UpdField UpdHow
h [Located Selector]
ls Expr PName
e) = UpdHow -> [Located Selector] -> Expr PName -> UpdField PName
forall n. UpdHow -> [Located Selector] -> Expr n -> UpdField n
UpdField UpdHow
h [Located Selector]
ls (Expr PName -> UpdField PName)
-> NoPatM (Expr PName) -> NoPatM (UpdField PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e

noPatFun :: [Pattern PName] -> Expr PName -> NoPatM ([Pattern PName], Expr PName)
noPatFun :: [Pattern PName]
-> Expr PName -> NoPatM ([Pattern PName], Expr PName)
noPatFun [Pattern PName]
ps Expr PName
e =
  do ([Pattern PName]
xs,[[Bind PName]]
bs) <- [(Pattern PName, [Bind PName])]
-> ([Pattern PName], [[Bind PName]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Pattern PName, [Bind PName])]
 -> ([Pattern PName], [[Bind PName]]))
-> NoPatM [(Pattern PName, [Bind PName])]
-> NoPatM ([Pattern PName], [[Bind PName]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern PName -> NoPatM (Pattern PName, [Bind PName]))
-> [Pattern PName] -> NoPatM [(Pattern PName, [Bind PName])]
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
     Expr PName
e1 <- Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
     let body :: Expr PName
body = case [[Bind PName]] -> [Bind PName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bind PName]]
bs of
                        [] -> Expr PName
e1
                        [Bind PName]
ds -> Expr PName -> [Decl PName] -> Expr PName
forall n. Expr n -> [Decl n] -> Expr n
EWhere Expr PName
e1 ([Decl PName] -> Expr PName) -> [Decl PName] -> Expr PName
forall a b. (a -> b) -> a -> b
$ (Bind PName -> Decl PName) -> [Bind PName] -> [Decl PName]
forall a b. (a -> b) -> [a] -> [b]
map Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind [Bind PName]
ds
     ([Pattern PName], Expr PName)
-> NoPatM ([Pattern PName], Expr PName)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pattern PName]
xs, Expr PName
body)


noPatArm :: [Match PName] -> NoPatM [Match PName]
noPatArm :: [Match PName] -> NoPatM [Match PName]
noPatArm [Match PName]
ms = [[Match PName]] -> [Match PName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Match PName]] -> [Match PName])
-> NoPatM [[Match PName]] -> NoPatM [Match PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Match PName -> NoPatM [Match PName])
-> [Match PName] -> NoPatM [[Match PName]]
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
     [Match PName] -> NoPatM [Match PName]
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern PName -> Expr PName -> Match PName
forall name. Pattern name -> Expr name -> Match name
Match Pattern PName
x Expr PName
e1 Match PName -> [Match PName] -> [Match PName]
forall a. a -> [a] -> [a]
: (Bind PName -> Match PName) -> [Bind PName] -> [Match PName]
forall a b. (a -> b) -> [a] -> [b]
map Bind PName -> Match PName
forall name. Bind name -> Match name
MatchLet [Bind PName]
bs)
noPatM (MatchLet Bind PName
b) = (Match PName -> [Match PName]
forall (m :: * -> *) a. Monad m => a -> m a
return (Match PName -> [Match PName])
-> (Bind PName -> Match PName) -> Bind PName -> [Match PName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bind PName -> Match PName
forall name. Bind name -> Match name
MatchLet) (Bind PName -> [Match PName])
-> NoPatM (Bind PName) -> NoPatM [Match PName]
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 Located (BindDef PName) -> BindDef PName
forall a. Located a -> a
thing (Bind PName -> Located (BindDef PName)
forall name. Bind name -> Located (BindDef name)
bDef Bind PName
b) of

    BindDef PName
DPrim | [Pattern PName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Bind PName -> [Pattern PName]
forall name. Bind name -> [Pattern name]
bParams Bind PName
b) -> Bind PName -> NoPatM (Bind PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Bind PName
b
          | Bool
otherwise        -> String -> [String] -> NoPatM (Bind PName)
forall a. HasCallStack => String -> [String] -> a
panic String
"NoPat" [ String
"noMatchB: primitive with params"
                                              , Bind PName -> String
forall a. Show a => a -> String
show Bind PName
b ]

    DExpr Expr PName
e ->
      do ([Pattern PName]
ps,Expr PName
e') <- [Pattern PName]
-> Expr PName -> NoPatM ([Pattern PName], Expr PName)
noPatFun (Bind PName -> [Pattern PName]
forall name. Bind name -> [Pattern name]
bParams Bind PName
b) Expr PName
e
         Bind PName -> NoPatM (Bind PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Bind PName
b { bParams :: [Pattern PName]
bParams = [Pattern PName]
ps, bDef :: Located (BindDef PName)
bDef = Expr PName -> BindDef PName
forall name. Expr name -> BindDef name
DExpr Expr PName
e' BindDef PName -> Located (BindDef PName) -> Located (BindDef PName)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bind PName -> Located (BindDef PName)
forall name. Bind name -> Located (BindDef name)
bDef Bind PName
b }

noMatchD :: Decl PName -> NoPatM [Decl PName]
noMatchD :: Decl PName -> NoPatM [Decl PName]
noMatchD Decl PName
decl =
  case Decl PName
decl of
    DSignature {}   -> [Decl PName] -> NoPatM [Decl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
    DPragma {}      -> [Decl PName] -> NoPatM [Decl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
    DFixity{}       -> [Decl PName] -> NoPatM [Decl PName]
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
                          [Decl PName] -> NoPatM [Decl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return [Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind PName
b1]

    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 = (Expr PName -> Type PName -> Expr PName)
-> Expr PName -> [Type PName] -> Expr PName
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr PName -> Type PName -> Expr PName
forall n. Expr n -> Type n -> Expr n
ETyped Expr PName
e1 [Type PName]
ts
                          [Decl PName] -> NoPatM [Decl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PName] -> NoPatM [Decl PName])
-> [Decl PName] -> NoPatM [Decl PName]
forall a b. (a -> b) -> a -> b
$ Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind :: forall name.
Located name
-> [Pattern name]
-> Located (BindDef name)
-> Maybe (Schema name)
-> Bool
-> Maybe Fixity
-> [Pragma]
-> Bool
-> Maybe Text
-> Bind name
Bind { bName :: Located PName
bName = Located PName
x
                                              , bParams :: [Pattern PName]
bParams = []
                                              , bDef :: Located (BindDef PName)
bDef = Expr PName -> Located (BindDef PName) -> Located (BindDef PName)
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Expr PName
e (Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located Range
emptyRange (Expr PName -> BindDef PName
forall name. Expr name -> BindDef name
DExpr Expr PName
e2))
                                              , bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
forall a. Maybe a
Nothing
                                              , bPragmas :: [Pragma]
bPragmas = []
                                              , bMono :: Bool
bMono = Bool
False
                                              , bInfix :: Bool
bInfix = Bool
False
                                              , bFixity :: Maybe Fixity
bFixity = Maybe Fixity
forall a. Maybe a
Nothing
                                              , bDoc :: Maybe Text
bDoc = Maybe Text
forall a. Maybe a
Nothing
                                              } Decl PName -> [Decl PName] -> [Decl PName]
forall a. a -> [a] -> [a]
: (Bind PName -> Decl PName) -> [Bind PName] -> [Decl PName]
forall a b. (a -> b) -> [a] -> [b]
map Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind [Bind PName]
bs
    DType {}        -> [Decl PName] -> NoPatM [Decl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
    DProp {}        -> [Decl PName] -> NoPatM [Decl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]

    DLocated Decl PName
d Range
r1   -> do [Decl PName]
bs <- Range -> NoPatM [Decl PName] -> NoPatM [Decl PName]
forall a. Range -> NoPatM a -> NoPatM a
inRange Range
r1 (NoPatM [Decl PName] -> NoPatM [Decl PName])
-> NoPatM [Decl PName] -> NoPatM [Decl PName]
forall a b. (a -> b) -> a -> b
$ Decl PName -> NoPatM [Decl PName]
noMatchD Decl PName
d
                          [Decl PName] -> NoPatM [Decl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PName] -> NoPatM [Decl PName])
-> [Decl PName] -> NoPatM [Decl PName]
forall a b. (a -> b) -> a -> b
$ (Decl PName -> Decl PName) -> [Decl PName] -> [Decl PName]
forall a b. (a -> b) -> [a] -> [b]
map (Decl PName -> Range -> Decl PName
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 <- [[Decl PName]] -> [Decl PName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Decl PName]] -> [Decl PName])
-> NoPatM [[Decl PName]] -> NoPatM [Decl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl PName -> NoPatM [Decl PName])
-> [Decl PName] -> NoPatM [[Decl PName]]
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 = ([Located Fixity] -> [Located Fixity] -> [Located Fixity])
-> [(PName, [Located Fixity])] -> Map PName [Located Fixity]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Located Fixity] -> [Located Fixity] -> [Located Fixity]
forall a. [a] -> [a] -> [a]
(++) ([(PName, [Located Fixity])] -> Map PName [Located Fixity])
-> [(PName, [Located Fixity])] -> Map PName [Located Fixity]
forall a b. (a -> b) -> a -> b
$ (Decl PName -> [(PName, [Located Fixity])])
-> [Decl PName] -> [(PName, [Located Fixity])]
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 :: Map PName [Located Pragma]
-> Map PName [Located (Schema PName)]
-> Map PName [Located Fixity]
-> Map PName [Located Fixity]
-> Map PName [Located Text]
-> AnnotMap
AnnotMap
           { annPragmas :: Map PName [Located Pragma]
annPragmas = ([Located Pragma] -> [Located Pragma] -> [Located Pragma])
-> [(PName, [Located Pragma])] -> Map PName [Located Pragma]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Located Pragma] -> [Located Pragma] -> [Located Pragma]
forall a. [a] -> [a] -> [a]
(++) ([(PName, [Located Pragma])] -> Map PName [Located Pragma])
-> [(PName, [Located Pragma])] -> Map PName [Located Pragma]
forall a b. (a -> b) -> a -> b
$ (Decl PName -> [(PName, [Located Pragma])])
-> [Decl PName] -> [(PName, [Located Pragma])]
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    = ([Located (Schema PName)]
 -> [Located (Schema PName)] -> [Located (Schema PName)])
-> [(PName, [Located (Schema PName)])]
-> Map PName [Located (Schema PName)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Located (Schema PName)]
-> [Located (Schema PName)] -> [Located (Schema PName)]
forall a. [a] -> [a] -> [a]
(++) ([(PName, [Located (Schema PName)])]
 -> Map PName [Located (Schema PName)])
-> [(PName, [Located (Schema PName)])]
-> Map PName [Located (Schema PName)]
forall a b. (a -> b) -> a -> b
$ (Decl PName -> [(PName, [Located (Schema PName)])])
-> [Decl PName] -> [(PName, [Located (Schema PName)])]
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    = Map PName [Located Text]
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]
.. }) <- AnnotMap
-> StateT AnnotMap NoPatM [Decl PName]
-> NoPatM ([Decl PName], AnnotMap)
forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT AnnotMap
amap (Annotates [Decl PName]
annotDs [Decl PName]
ds1)

     [(PName, [Located Pragma])]
-> ((PName, [Located Pragma]) -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PName [Located Pragma] -> [(PName, [Located Pragma])]
forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Located Pragma]
annPragmas) (((PName, [Located Pragma]) -> NoPatM ()) -> NoPatM ())
-> ((PName, [Located Pragma]) -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located Pragma]
ps) ->
       [Located Pragma] -> (Located Pragma -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located Pragma]
ps ((Located Pragma -> NoPatM ()) -> NoPatM ())
-> (Located Pragma -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \Located Pragma
p -> Error -> NoPatM ()
recordError (Error -> NoPatM ()) -> Error -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ Located PName -> Pragma -> Error
PragmaNoBind (Located Pragma
p { thing :: PName
thing = PName
n }) (Located Pragma -> Pragma
forall a. Located a -> a
thing Located Pragma
p)

     [(PName, [Located (Schema PName)])]
-> ((PName, [Located (Schema PName)]) -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PName [Located (Schema PName)]
-> [(PName, [Located (Schema PName)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Located (Schema PName)]
annSigs) (((PName, [Located (Schema PName)]) -> NoPatM ()) -> NoPatM ())
-> ((PName, [Located (Schema PName)]) -> NoPatM ()) -> NoPatM ()
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
          [Located (Schema PName)]
-> (Located (Schema PName) -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located (Schema PName)]
ss ((Located (Schema PName) -> NoPatM ()) -> NoPatM ())
-> (Located (Schema PName) -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \Located (Schema PName)
s -> Error -> NoPatM ()
recordError (Error -> NoPatM ()) -> Error -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ Located PName -> Schema PName -> Error
SignatureNoBind (Located (Schema PName)
s { thing :: PName
thing = PName
n })
                                                         (Located (Schema PName) -> Schema PName
forall a. Located a -> a
thing Located (Schema PName)
s)

     -- Generate an error if a fixity declaration is not used for
     -- either a value-level or type-level operator.
     [(PName, [Located Fixity])]
-> ((PName, [Located Fixity]) -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PName [Located Fixity] -> [(PName, [Located Fixity])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map PName [Located Fixity]
-> Map PName [Located Fixity] -> Map PName [Located Fixity]
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)) (((PName, [Located Fixity]) -> NoPatM ()) -> NoPatM ())
-> ((PName, [Located Fixity]) -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located Fixity]
fs) ->
       [Located Fixity] -> (Located Fixity -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located Fixity]
fs ((Located Fixity -> NoPatM ()) -> NoPatM ())
-> (Located Fixity -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \Located Fixity
f -> Error -> NoPatM ()
recordError (Error -> NoPatM ()) -> Error -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ Located PName -> Error
FixityNoBind Located Fixity
f { thing :: PName
thing = PName
n }

     [Decl PName] -> NoPatM [Decl PName]
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 <- [[TopDecl PName]] -> [TopDecl PName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TopDecl PName]] -> [TopDecl PName])
-> NoPatM [[TopDecl PName]] -> NoPatM [TopDecl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TopDecl PName -> NoPatM [TopDecl PName])
-> [TopDecl PName] -> NoPatM [[TopDecl PName]]
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  = (TopLevel (Decl PName) -> Decl PName)
-> [TopLevel (Decl PName)] -> [Decl PName]
forall a b. (a -> b) -> [a] -> [b]
map TopLevel (Decl PName) -> Decl PName
forall a. TopLevel a -> a
tlValue ([TopDecl PName] -> [TopLevel (Decl PName)]
forall name. [TopDecl name] -> [TopLevel (Decl name)]
decls [TopDecl PName]
desugared)
         fixes :: Map PName [Located Fixity]
fixes     = ([Located Fixity] -> [Located Fixity] -> [Located Fixity])
-> [(PName, [Located Fixity])] -> Map PName [Located Fixity]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Located Fixity] -> [Located Fixity] -> [Located Fixity]
forall a. [a] -> [a] -> [a]
(++) ([(PName, [Located Fixity])] -> Map PName [Located Fixity])
-> [(PName, [Located Fixity])] -> Map PName [Located Fixity]
forall a b. (a -> b) -> a -> b
$ (Decl PName -> [(PName, [Located Fixity])])
-> [Decl PName] -> [(PName, [Located Fixity])]
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 :: Map PName [Located Pragma]
-> Map PName [Located (Schema PName)]
-> Map PName [Located Fixity]
-> Map PName [Located Fixity]
-> Map PName [Located Text]
-> AnnotMap
AnnotMap
           { annPragmas :: Map PName [Located Pragma]
annPragmas = ([Located Pragma] -> [Located Pragma] -> [Located Pragma])
-> [(PName, [Located Pragma])] -> Map PName [Located Pragma]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Located Pragma] -> [Located Pragma] -> [Located Pragma]
forall a. [a] -> [a] -> [a]
(++) ([(PName, [Located Pragma])] -> Map PName [Located Pragma])
-> [(PName, [Located Pragma])] -> Map PName [Located Pragma]
forall a b. (a -> b) -> a -> b
$ (Decl PName -> [(PName, [Located Pragma])])
-> [Decl PName] -> [(PName, [Located Pragma])]
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    = ([Located (Schema PName)]
 -> [Located (Schema PName)] -> [Located (Schema PName)])
-> [(PName, [Located (Schema PName)])]
-> Map PName [Located (Schema PName)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Located (Schema PName)]
-> [Located (Schema PName)] -> [Located (Schema PName)]
forall a. [a] -> [a] -> [a]
(++) ([(PName, [Located (Schema PName)])]
 -> Map PName [Located (Schema PName)])
-> [(PName, [Located (Schema PName)])]
-> Map PName [Located (Schema PName)]
forall a b. (a -> b) -> a -> b
$ (Decl PName -> [(PName, [Located (Schema PName)])])
-> [Decl PName] -> [(PName, [Located (Schema PName)])]
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    = ([Located Text] -> [Located Text] -> [Located Text])
-> [(PName, [Located Text])] -> Map PName [Located Text]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Located Text] -> [Located Text] -> [Located Text]
forall a. [a] -> [a] -> [a]
(++) ([(PName, [Located Text])] -> Map PName [Located Text])
-> [(PName, [Located Text])] -> Map PName [Located Text]
forall a b. (a -> b) -> a -> b
$ (TopLevel (Decl PName) -> [(PName, [Located Text])])
-> [TopLevel (Decl PName)] -> [(PName, [Located Text])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TopLevel (Decl PName) -> [(PName, [Located Text])]
toDocs ([TopLevel (Decl PName)] -> [(PName, [Located Text])])
-> [TopLevel (Decl PName)] -> [(PName, [Located Text])]
forall a b. (a -> b) -> a -> b
$ [TopDecl PName] -> [TopLevel (Decl PName)]
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]
.. }) <- AnnotMap
-> StateT AnnotMap NoPatM [TopDecl PName]
-> NoPatM ([TopDecl PName], AnnotMap)
forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT AnnotMap
ann (Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
desugared)

     [(PName, [Located Pragma])]
-> ((PName, [Located Pragma]) -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PName [Located Pragma] -> [(PName, [Located Pragma])]
forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Located Pragma]
annPragmas) (((PName, [Located Pragma]) -> NoPatM ()) -> NoPatM ())
-> ((PName, [Located Pragma]) -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located Pragma]
ps) ->
       [Located Pragma] -> (Located Pragma -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located Pragma]
ps ((Located Pragma -> NoPatM ()) -> NoPatM ())
-> (Located Pragma -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \Located Pragma
p -> Error -> NoPatM ()
recordError (Error -> NoPatM ()) -> Error -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ Located PName -> Pragma -> Error
PragmaNoBind (Located Pragma
p { thing :: PName
thing = PName
n }) (Located Pragma -> Pragma
forall a. Located a -> a
thing Located Pragma
p)

     [(PName, [Located (Schema PName)])]
-> ((PName, [Located (Schema PName)]) -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PName [Located (Schema PName)]
-> [(PName, [Located (Schema PName)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Located (Schema PName)]
annSigs) (((PName, [Located (Schema PName)]) -> NoPatM ()) -> NoPatM ())
-> ((PName, [Located (Schema PName)]) -> NoPatM ()) -> NoPatM ()
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
          [Located (Schema PName)]
-> (Located (Schema PName) -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located (Schema PName)]
ss ((Located (Schema PName) -> NoPatM ()) -> NoPatM ())
-> (Located (Schema PName) -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \Located (Schema PName)
s -> Error -> NoPatM ()
recordError (Error -> NoPatM ()) -> Error -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ Located PName -> Schema PName -> Error
SignatureNoBind (Located (Schema PName)
s { thing :: PName
thing = PName
n })
                                                         (Located (Schema PName) -> Schema PName
forall a. Located a -> a
thing Located (Schema PName)
s)

     -- Generate an error if a fixity declaration is not used for
     -- either a value-level or type-level operator.
     [(PName, [Located Fixity])]
-> ((PName, [Located Fixity]) -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PName [Located Fixity] -> [(PName, [Located Fixity])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map PName [Located Fixity]
-> Map PName [Located Fixity] -> Map PName [Located Fixity]
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)) (((PName, [Located Fixity]) -> NoPatM ()) -> NoPatM ())
-> ((PName, [Located Fixity]) -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \(PName
n,[Located Fixity]
fs) ->
       [Located Fixity] -> (Located Fixity -> NoPatM ()) -> NoPatM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Located Fixity]
fs ((Located Fixity -> NoPatM ()) -> NoPatM ())
-> (Located Fixity -> NoPatM ()) -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ \Located Fixity
f -> Error -> NoPatM ()
recordError (Error -> NoPatM ()) -> Error -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ Located PName -> Error
FixityNoBind Located Fixity
f { thing :: PName
thing = PName
n }

     [TopDecl PName] -> NoPatM [TopDecl PName]
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 (TopLevel (Decl PName) -> Decl PName
forall a. TopLevel a -> a
tlValue TopLevel (Decl PName)
tl)
                    [TopDecl PName] -> NoPatM [TopDecl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return [ TopLevel (Decl PName) -> TopDecl PName
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      -> [TopDecl PName] -> NoPatM [TopDecl PName]
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) = [TopDecl PName] -> Program PName
forall name. [TopDecl name] -> Program name
Program ([TopDecl PName] -> Program PName)
-> NoPatM [TopDecl PName] -> NoPatM (Program PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs [TopDecl PName]
topDs

noPatModule :: Module PName -> NoPatM (Module PName)
noPatModule :: Module PName -> NoPatM (Module PName)
noPatModule Module PName
m =
  do [TopDecl PName]
ds1 <- [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs (Module PName -> [TopDecl PName]
forall name. Module name -> [TopDecl name]
mDecls Module PName
m)
     Module PName -> NoPatM (Module PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Module PName
m { mDecls :: [TopDecl PName]
mDecls = [TopDecl PName]
ds1 }

--------------------------------------------------------------------------------

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

-- | Add annotations to exported declaration groups.
--
-- XXX: This isn't quite right: if a signature and binding have different
-- export specifications, this will favor the specification of the binding.
-- This is most likely the intended behavior, so it's probably fine, but it does
-- smell a bit.
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 <- ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
-> StateT AnnotMap NoPatM (Either () (Decl PName))
forall i (m :: * -> *) a. ExceptionT i m a -> m (Either i a)
runExceptionT (Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD (TopLevel (Decl PName) -> Decl PName
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 -> (TopLevel (Decl PName) -> TopDecl PName
forall name. TopLevel (Decl name) -> TopDecl name
Decl (TopLevel (Decl PName)
d1 { tlValue :: Decl PName
tlValue = Decl PName
d2 }) TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
:) ([TopDecl PName] -> [TopDecl PName])
-> StateT AnnotMap NoPatM [TopDecl PName]
-> StateT AnnotMap NoPatM [TopDecl PName]
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 (TopLevel (PrimType PName) -> PrimType PName
forall a. TopLevel a -> a
tlValue TopLevel (PrimType PName)
tl)
             let d1 :: TopDecl PName
d1 = TopLevel (PrimType PName) -> TopDecl PName
forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel (PrimType PName)
tl { tlValue :: PrimType PName
tlValue = PrimType PName
pt }
             (TopDecl PName
d1 TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
:) ([TopDecl PName] -> [TopDecl PName])
-> StateT AnnotMap NoPatM [TopDecl PName]
-> StateT AnnotMap NoPatM [TopDecl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds

        DParameterType ParameterType PName
p ->
          do ParameterType PName
p1 <- Annotates (ParameterType PName)
annotParameterType ParameterType PName
p
             (ParameterType PName -> TopDecl PName
forall name. ParameterType name -> TopDecl name
DParameterType ParameterType PName
p1 TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
:) ([TopDecl PName] -> [TopDecl PName])
-> StateT AnnotMap NoPatM [TopDecl PName]
-> StateT AnnotMap NoPatM [TopDecl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds

        DParameterConstraint {} -> (TopDecl PName
d TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
:) ([TopDecl PName] -> [TopDecl PName])
-> StateT AnnotMap NoPatM [TopDecl PName]
-> StateT AnnotMap NoPatM [TopDecl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds

        DParameterFun ParameterFun PName
p ->
          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]
.. } <- StateT AnnotMap NoPatM AnnotMap
forall (m :: * -> *) i. StateM m i => m i
get
             let rm :: p -> p -> Maybe a
rm p
_ p
_ = Maybe a
forall a. Maybe a
Nothing
                 name :: PName
name = Located PName -> PName
forall a. Located a -> a
thing (ParameterFun PName -> Located PName
forall name. ParameterFun name -> Located name
pfName ParameterFun PName
p)
             case (PName -> [Located Fixity] -> Maybe [Located Fixity])
-> PName
-> Map PName [Located Fixity]
-> (Maybe [Located Fixity], Map PName [Located Fixity])
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey PName -> [Located Fixity] -> Maybe [Located Fixity]
forall p p a. p -> p -> Maybe a
rm PName
name Map PName [Located Fixity]
annValueFs of
               (Maybe [Located Fixity]
Nothing,Map PName [Located Fixity]
_)  -> (TopDecl PName
d TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
:) ([TopDecl PName] -> [TopDecl PName])
-> StateT AnnotMap NoPatM [TopDecl PName]
-> StateT AnnotMap NoPatM [TopDecl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
               (Just [Located Fixity]
f,Map PName [Located Fixity]
fs1) ->
                 do Maybe Fixity
mbF <- NoPatM (Maybe Fixity) -> StateT AnnotMap NoPatM (Maybe Fixity)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs PName
name [Located Fixity]
f)
                    AnnotMap -> StateT AnnotMap NoPatM ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set AnnotMap :: Map PName [Located Pragma]
-> Map PName [Located (Schema PName)]
-> Map PName [Located Fixity]
-> Map PName [Located Fixity]
-> Map PName [Located Text]
-> AnnotMap
AnnotMap { annValueFs :: Map PName [Located Fixity]
annValueFs = Map PName [Located Fixity]
fs1, 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]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annTypeFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
.. }
                    let p1 :: ParameterFun PName
p1 = ParameterFun PName
p { pfFixity :: Maybe Fixity
pfFixity = Maybe Fixity
mbF }
                    (ParameterFun PName -> TopDecl PName
forall name. ParameterFun name -> TopDecl name
DParameterFun ParameterFun PName
p1 TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
:) ([TopDecl PName] -> [TopDecl PName])
-> StateT AnnotMap NoPatM [TopDecl PName]
-> StateT AnnotMap NoPatM [TopDecl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds

        -- XXX: we may want to add pragmas to newtypes?
        TDNewtype {} -> (TopDecl PName
d TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
:) ([TopDecl PName] -> [TopDecl PName])
-> StateT AnnotMap NoPatM [TopDecl PName]
-> StateT AnnotMap NoPatM [TopDecl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
        Include {}   -> (TopDecl PName
d TopDecl PName -> [TopDecl PName] -> [TopDecl PName]
forall a. a -> [a] -> [a]
:) ([TopDecl PName] -> [TopDecl PName])
-> StateT AnnotMap NoPatM [TopDecl PName]
-> StateT AnnotMap NoPatM [TopDecl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds

    [] -> Annotates [TopDecl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return []


-- | Add annotations, keeping track of which annotations are not yet used up.
annotDs :: Annotates [Decl PName]
annotDs :: Annotates [Decl PName]
annotDs (Decl PName
d : [Decl PName]
ds) =
  do Either () (Decl PName)
ignore <- ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
-> StateT AnnotMap NoPatM (Either () (Decl PName))
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 Decl PName -> [Decl PName] -> [Decl PName]
forall a. a -> [a] -> [a]
:) ([Decl PName] -> [Decl PName])
-> StateT AnnotMap NoPatM [Decl PName]
-> StateT AnnotMap NoPatM [Decl PName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [Decl PName]
annotDs [Decl PName]
ds
annotDs [] = Annotates [Decl PName]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Add annotations, keeping track of which annotations are not yet used up.
-- The exception indicates which declarations are no longer needed.
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       -> Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind (Bind PName -> Decl PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (Bind PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AnnotMap NoPatM (Bind PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (Bind PName)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (Annotates (Bind PName)
annotB Bind PName
b)
    DSignature {} -> () -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
    DFixity{}     -> () -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
    DPragma {}    -> () -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
    DPatBind {}   -> () -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
    DType TySyn PName
tysyn   -> TySyn PName -> Decl PName
forall name. TySyn name -> Decl name
DType (TySyn PName -> Decl PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (TySyn PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AnnotMap NoPatM (TySyn PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (TySyn PName)
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 -> PropSyn PName -> Decl PName
forall name. PropSyn name -> Decl name
DProp (PropSyn PName -> Decl PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (PropSyn PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AnnotMap NoPatM (PropSyn PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (PropSyn PName)
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  -> (Decl PName -> Range -> Decl PName
forall name. Decl name -> Range -> Decl name
`DLocated` Range
r) (Decl PName -> Decl PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
-> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD Decl PName
d

-- | Add pragma/signature annotations to a binding.
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)
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
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]
.. } <- StateT AnnotMap NoPatM AnnotMap
forall (m :: * -> *) i. StateM m i => m i
get
     let name :: PName
name       = Located PName -> PName
forall a. Located a -> a
thing Located PName
bName
         remove :: p -> p -> Maybe a
remove p
_ p
_ = Maybe a
forall a. Maybe a
Nothing
         (Maybe [Located Pragma]
thisPs    , Map PName [Located Pragma]
ps') = (PName -> [Located Pragma] -> Maybe [Located Pragma])
-> PName
-> Map PName [Located Pragma]
-> (Maybe [Located Pragma], Map PName [Located Pragma])
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey PName -> [Located Pragma] -> Maybe [Located Pragma]
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') = (PName
 -> [Located (Schema PName)] -> Maybe [Located (Schema PName)])
-> PName
-> Map PName [Located (Schema PName)]
-> (Maybe [Located (Schema PName)],
    Map PName [Located (Schema PName)])
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey PName -> [Located (Schema PName)] -> Maybe [Located (Schema PName)]
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') = (PName -> [Located Fixity] -> Maybe [Located Fixity])
-> PName
-> Map PName [Located Fixity]
-> (Maybe [Located Fixity], Map PName [Located Fixity])
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey PName -> [Located Fixity] -> Maybe [Located Fixity]
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') = (PName -> [Located Text] -> Maybe [Located Text])
-> PName
-> Map PName [Located Text]
-> (Maybe [Located Text], Map PName [Located Text])
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey PName -> [Located Text] -> Maybe [Located Text]
forall p p a. p -> p -> Maybe a
remove PName
name Map PName [Located Text]
annDocs
     Maybe (Schema PName)
s <- NoPatM (Maybe (Schema PName))
-> StateT AnnotMap NoPatM (Maybe (Schema PName))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (NoPatM (Maybe (Schema PName))
 -> StateT AnnotMap NoPatM (Maybe (Schema PName)))
-> NoPatM (Maybe (Schema PName))
-> StateT AnnotMap NoPatM (Maybe (Schema PName))
forall a b. (a -> b) -> a -> b
$ PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs PName
name ([Located (Schema PName)] -> NoPatM (Maybe (Schema PName)))
-> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
forall a b. (a -> b) -> a -> b
$ Maybe [Located (Schema PName)] -> [Located (Schema PName)]
forall a. Maybe [a] -> [a]
jn Maybe [Located (Schema PName)]
thisSigs
     Maybe Fixity
f <- NoPatM (Maybe Fixity) -> StateT AnnotMap NoPatM (Maybe Fixity)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (NoPatM (Maybe Fixity) -> StateT AnnotMap NoPatM (Maybe Fixity))
-> NoPatM (Maybe Fixity) -> StateT AnnotMap NoPatM (Maybe Fixity)
forall a b. (a -> b) -> a -> b
$ PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs PName
name ([Located Fixity] -> NoPatM (Maybe Fixity))
-> [Located Fixity] -> NoPatM (Maybe Fixity)
forall a b. (a -> b) -> a -> b
$ Maybe [Located Fixity] -> [Located Fixity]
forall a. Maybe [a] -> [a]
jn Maybe [Located Fixity]
thisFixes
     Maybe Text
d <- NoPatM (Maybe Text) -> StateT AnnotMap NoPatM (Maybe Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (NoPatM (Maybe Text) -> StateT AnnotMap NoPatM (Maybe Text))
-> NoPatM (Maybe Text) -> StateT AnnotMap NoPatM (Maybe Text)
forall a b. (a -> b) -> a -> b
$ PName -> [Located Text] -> NoPatM (Maybe Text)
checkDocs PName
name ([Located Text] -> NoPatM (Maybe Text))
-> [Located Text] -> NoPatM (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Maybe [Located Text] -> [Located Text]
forall a. Maybe [a] -> [a]
jn Maybe [Located Text]
thisDocs
     AnnotMap -> StateT AnnotMap NoPatM ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set AnnotMap :: Map PName [Located Pragma]
-> Map PName [Located (Schema PName)]
-> Map PName [Located Fixity]
-> Map PName [Located Fixity]
-> Map PName [Located Text]
-> AnnotMap
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]
..
                  }
     Annotates (Bind PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Bind :: forall name.
Located name
-> [Pattern name]
-> Located (BindDef name)
-> Maybe (Schema name)
-> Bool
-> Maybe Fixity
-> [Pragma]
-> Bool
-> Maybe Text
-> Bind name
Bind { bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
s
                 , bPragmas :: [Pragma]
bPragmas = (Located Pragma -> Pragma) -> [Located Pragma] -> [Pragma]
forall a b. (a -> b) -> [a] -> [b]
map Located Pragma -> Pragma
forall a. Located a -> a
thing (Maybe [Located Pragma] -> [Located Pragma]
forall a. Maybe [a] -> [a]
jn Maybe [Located Pragma]
thisPs) [Pragma] -> [Pragma] -> [Pragma]
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)
bMono :: Bool
bInfix :: Bool
bDef :: Located (BindDef PName)
bParams :: [Pattern PName]
bName :: Located PName
bInfix :: Bool
bMono :: Bool
bDef :: Located (BindDef PName)
bParams :: [Pattern PName]
bName :: Located PName
..
                 }
  where jn :: Maybe [a] -> [a]
jn Maybe [a]
x = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Maybe [a] -> [[a]]
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]
.. } <- StateT AnnotMap NoPatM AnnotMap
forall (m :: * -> *) i. StateM m i => m i
get
     let remove :: p -> p -> Maybe a
remove p
_ p
_ = Maybe a
forall a. Maybe a
Nothing
         (Maybe [Located Fixity]
thisFixes, Map PName [Located Fixity]
ts') = (PName -> [Located Fixity] -> Maybe [Located Fixity])
-> PName
-> Map PName [Located Fixity]
-> (Maybe [Located Fixity], Map PName [Located Fixity])
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey PName -> [Located Fixity] -> Maybe [Located Fixity]
forall p p a. p -> p -> Maybe a
remove PName
name Map PName [Located Fixity]
annTypeFs
     Maybe Fixity
f <- NoPatM (Maybe Fixity) -> StateT AnnotMap NoPatM (Maybe Fixity)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (NoPatM (Maybe Fixity) -> StateT AnnotMap NoPatM (Maybe Fixity))
-> NoPatM (Maybe Fixity) -> StateT AnnotMap NoPatM (Maybe Fixity)
forall a b. (a -> b) -> a -> b
$ PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs PName
name ([Located Fixity] -> NoPatM (Maybe Fixity))
-> [Located Fixity] -> NoPatM (Maybe Fixity)
forall a b. (a -> b) -> a -> b
$ [[Located Fixity]] -> [Located Fixity]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Located Fixity]] -> [Located Fixity])
-> [[Located Fixity]] -> [Located Fixity]
forall a b. (a -> b) -> a -> b
$ Maybe [Located Fixity] -> [[Located Fixity]]
forall a. Maybe a -> [a]
maybeToList Maybe [Located Fixity]
thisFixes
     AnnotMap -> StateT AnnotMap NoPatM ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set AnnotMap :: Map PName [Located Pragma]
-> Map PName [Located (Schema PName)]
-> Map PName [Located Fixity]
-> Map PName [Located Fixity]
-> Map PName [Located Text]
-> AnnotMap
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]
.. }
     Maybe Fixity -> StateT AnnotMap NoPatM (Maybe Fixity)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Fixity
f


-- | Add fixity annotations to a type synonym binding.
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 (Located PName -> PName
forall a. Located a -> a
thing Located PName
ln)
     Annotates (TySyn PName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located PName
-> Maybe Fixity -> [TParam PName] -> Type PName -> TySyn PName
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)

-- | Add fixity annotations to a constraint synonym binding.
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 (Located PName -> PName
forall a. Located a -> a
thing Located PName
ln)
     Annotates (PropSyn PName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located PName
-> Maybe Fixity -> [TParam PName] -> [Prop PName] -> PropSyn PName
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)

-- | Annotate a primitive type declaration.
annotPrimType :: Annotates (PrimType PName)
annotPrimType :: Annotates (PrimType PName)
annotPrimType PrimType PName
pt =
  do Maybe Fixity
f <- PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing (Located PName -> PName
forall a. Located a -> a
thing (PrimType PName -> Located PName
forall name. PrimType name -> Located name
primTName PrimType PName
pt))
     Annotates (PrimType PName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimType PName
pt { primTFixity :: Maybe Fixity
primTFixity = Maybe Fixity
f }

-- | Annotate a module's type parameter.
annotParameterType :: Annotates (ParameterType PName)
annotParameterType :: Annotates (ParameterType PName)
annotParameterType ParameterType PName
pt =
  do Maybe Fixity
f <- PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing (Located PName -> PName
forall a. Located a -> a
thing (ParameterType PName -> Located PName
forall name. ParameterType name -> Located name
ptName ParameterType PName
pt))
     Annotates (ParameterType PName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParameterType PName
pt { ptFixity :: Maybe Fixity
ptFixity = Maybe Fixity
f }




-- | Check for multiple signatures.
checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs PName
_ []             = Maybe (Schema PName) -> NoPatM (Maybe (Schema PName))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Schema PName)
forall a. Maybe a
Nothing
checkSigs PName
_ [Located (Schema PName)
s]            = Maybe (Schema PName) -> NoPatM (Maybe (Schema PName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema PName -> Maybe (Schema PName)
forall a. a -> Maybe a
Just (Located (Schema PName) -> Schema PName
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 (Error -> NoPatM ()) -> Error -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ PName -> [Located (Schema PName)] -> Error
MultipleSignatures PName
f [Located (Schema PName)]
xs
                                Maybe (Schema PName) -> NoPatM (Maybe (Schema PName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema PName -> Maybe (Schema PName)
forall a. a -> Maybe a
Just (Located (Schema PName) -> Schema PName
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
_ []       = Maybe Fixity -> NoPatM (Maybe Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Fixity
forall a. Maybe a
Nothing
checkFixs PName
_ [Located Fixity
f]      = Maybe Fixity -> NoPatM (Maybe Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just (Located Fixity -> Fixity
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 (Error -> NoPatM ()) -> Error -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ PName -> [Range] -> Error
MultipleFixities PName
f ([Range] -> Error) -> [Range] -> Error
forall a b. (a -> b) -> a -> b
$ (Located Fixity -> Range) -> [Located Fixity] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map Located Fixity -> Range
forall a. Located a -> Range
srcRange [Located Fixity]
fs
                          Maybe Fixity -> NoPatM (Maybe Fixity)
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just (Located Fixity -> Fixity
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
_ []       = Maybe Text -> NoPatM (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
checkDocs PName
_ [Located Text
d]      = Maybe Text -> NoPatM (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text
forall a. a -> Maybe a
Just (Located Text -> Text
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 (Error -> NoPatM ()) -> Error -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ PName -> [Range] -> Error
MultipleDocs PName
f ((Located Text -> Range) -> [Located Text] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map Located Text -> Range
forall a. Located a -> Range
srcRange [Located Text]
ds)
                          Maybe Text -> NoPatM (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text
forall a. a -> Maybe a
Just (Located Text -> Text
forall a. Located a -> a
thing Located Text
d))


-- | Does this declaration provide some signatures?
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)   = [ (Located PName -> PName
forall a. Located a -> a
thing Located PName
x,[Range -> Schema PName -> Located (Schema PName)
forall a. Range -> a -> Located a
Located (Located PName -> Range
forall a. Located a -> Range
srcRange Located PName
x) Schema PName
s]) | Located PName
x <- [Located PName]
xs ]
toSig Decl PName
_                   = []

-- | Does this declaration provide some signatures?
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)   = [ (Located PName -> PName
forall a. Located a -> a
thing Located PName
x,[Range -> Pragma -> Located Pragma
forall a. Range -> a -> Located a
Located (Located PName -> Range
forall a. Located a -> Range
srcRange Located PName
x) Pragma
s]) | Located PName
x <- [Located PName]
xs ]
toPragma Decl PName
_                = []

-- | Does this declaration provide fixity information?
toFixity :: Decl PName -> [(PName, [Located Fixity])]
toFixity :: Decl PName -> [(PName, [Located Fixity])]
toFixity (DFixity Fixity
f [Located PName]
ns) = [ (Located PName -> PName
forall a. Located a -> a
thing Located PName
n, [Range -> Fixity -> Located Fixity
forall a. Range -> a -> Located a
Located (Located PName -> Range
forall a. Located a -> Range
srcRange Located PName
n) Fixity
f]) | Located PName
n <- [Located PName]
ns ]
toFixity Decl PName
_              = []

-- | Does this top-level declaration provide a documentation string?
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 = Located Text -> Decl PName -> [(PName, [Located Text])]
forall t a. t -> Decl a -> [(a, [t])]
go Located Text
txt Decl PName
tlValue
  | Bool
otherwise = []
  where
  go :: t -> Decl a -> [(a, [t])]
go t
txt Decl a
decl =
    case Decl a
decl of
      DSignature [Located a]
ns Schema a
_ -> [ (Located a -> a
forall a. Located a -> a
thing Located a
n, [t
txt]) | Located a
n <- [Located a]
ns ]
      DFixity Fixity
_ [Located a]
ns    -> [ (Located a -> a
forall a. Located a -> a
thing Located a
n, [t
txt]) | Located a
n <- [Located a]
ns ]
      DBind Bind a
b         -> [ (Located a -> a
forall a. Located a -> a
thing (Bind a -> Located a
forall name. Bind name -> Located name
bName Bind a
b), [t
txt]) ]
      DLocated Decl a
d Range
_    -> t -> Decl a -> [(a, [t])]
go t
txt Decl a
d
      DPatBind Pattern a
p Expr a
_    -> [ (Located a -> a
forall a. Located a -> a
thing Located a
n, [t
txt]) | Located a
n <- Pattern a -> [Located a]
forall name. Pattern name -> [Located name]
namesP Pattern a
p ]

      -- XXX revisit these
      DPragma [Located a]
_ Pragma
_     -> []
      DType TySyn a
_         -> []
      DProp PropSyn a
_         -> []


--------------------------------------------------------------------------------
newtype NoPatM a = M { 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
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
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. Error -> Rep Error x)
-> (forall x. Rep Error x -> Error) -> Generic Error
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 -> ()
(Error -> ()) -> NFData Error
forall a. (a -> ()) -> NFData a
rnf :: Error -> ()
$crnf :: Error -> ()
NFData)

instance Functor NoPatM where fmap :: (a -> b) -> NoPatM a -> NoPatM b
fmap = (a -> b) -> NoPatM a -> NoPatM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative NoPatM where pure :: a -> NoPatM a
pure = a -> NoPatM a
forall (m :: * -> *) a. Monad m => a -> m a
return; <*> :: NoPatM (a -> b) -> NoPatM a -> NoPatM 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 :: a -> NoPatM a
return a
x  = ReaderT Range (StateT RW Id) a -> NoPatM a
forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M (a -> ReaderT Range (StateT RW Id) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x)
  M ReaderT Range (StateT RW Id) a
x >>= :: NoPatM a -> (a -> NoPatM b) -> NoPatM b
>>= a -> NoPatM b
k = ReaderT Range (StateT RW Id) b -> NoPatM b
forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M (ReaderT Range (StateT RW Id) a
x ReaderT Range (StateT RW Id) a
-> (a -> ReaderT Range (StateT RW Id) b)
-> ReaderT Range (StateT RW Id) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NoPatM b -> ReaderT Range (StateT RW Id) b
forall a. NoPatM a -> ReaderT Range (StateT RW Id) a
unM (NoPatM b -> ReaderT Range (StateT RW Id) b)
-> (a -> NoPatM b) -> a -> ReaderT Range (StateT RW Id) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NoPatM b
k)

-- | Pick a new name, to be used when desugaring patterns.
newName :: NoPatM PName
newName :: NoPatM PName
newName = ReaderT Range (StateT RW Id) PName -> NoPatM PName
forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M (ReaderT Range (StateT RW Id) PName -> NoPatM PName)
-> ReaderT Range (StateT RW Id) PName -> NoPatM PName
forall a b. (a -> b) -> a -> b
$ (RW -> (PName, RW)) -> ReaderT Range (StateT RW Id) PName
forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets ((RW -> (PName, RW)) -> ReaderT Range (StateT RW Id) PName)
-> (RW -> (PName, RW)) -> ReaderT Range (StateT RW Id) PName
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 })

-- | Record an error.
recordError :: Error -> NoPatM ()
recordError :: Error -> NoPatM ()
recordError Error
e = ReaderT Range (StateT RW Id) () -> NoPatM ()
forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M (ReaderT Range (StateT RW Id) () -> NoPatM ())
-> ReaderT Range (StateT RW Id) () -> NoPatM ()
forall a b. (a -> b) -> a -> b
$ (RW -> RW) -> ReaderT Range (StateT RW Id) ()
forall (m :: * -> *) s. StateM m s => (s -> s) -> m ()
sets_ ((RW -> RW) -> ReaderT Range (StateT RW Id) ())
-> (RW -> RW) -> ReaderT Range (StateT RW Id) ()
forall a b. (a -> b) -> a -> b
$ \RW
s -> RW
s { errors :: [Error]
errors = Error
e Error -> [Error] -> [Error]
forall a. a -> [a] -> [a]
: RW -> [Error]
errors RW
s }

getRange :: NoPatM Range
getRange :: NoPatM Range
getRange = ReaderT Range (StateT RW Id) Range -> NoPatM Range
forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M ReaderT Range (StateT RW Id) Range
forall (m :: * -> *) i. ReaderM m i => m i
ask

inRange :: Range -> NoPatM a -> NoPatM a
inRange :: Range -> NoPatM a -> NoPatM a
inRange Range
r NoPatM a
m = ReaderT Range (StateT RW Id) a -> NoPatM a
forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M (ReaderT Range (StateT RW Id) a -> NoPatM a)
-> ReaderT Range (StateT RW Id) a -> NoPatM a
forall a b. (a -> b) -> a -> b
$ Range
-> ReaderT Range (StateT RW Id) a -> ReaderT Range (StateT RW Id) a
forall (m :: * -> *) i a. RunReaderM m i => i -> m a -> m a
local Range
r (ReaderT Range (StateT RW Id) a -> ReaderT Range (StateT RW Id) a)
-> ReaderT Range (StateT RW Id) a -> ReaderT Range (StateT RW Id) a
forall a b. (a -> b) -> a -> b
$ NoPatM a -> ReaderT Range (StateT RW Id) a
forall a. NoPatM a -> ReaderT Range (StateT RW Id) a
unM NoPatM a
m


runNoPatM :: NoPatM a -> (a, [Error])
runNoPatM :: NoPatM a -> (a, [Error])
runNoPatM NoPatM a
m
  = (a, RW) -> (a, [Error])
forall a. (a, RW) -> (a, [Error])
getErrs
  ((a, RW) -> (a, [Error])) -> (a, RW) -> (a, [Error])
forall a b. (a -> b) -> a -> b
$ Id (a, RW) -> (a, RW)
forall a. Id a -> a
runId
  (Id (a, RW) -> (a, RW)) -> Id (a, RW) -> (a, RW)
forall a b. (a -> b) -> a -> b
$ RW -> StateT RW Id a -> Id (a, RW)
forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT RW :: Int -> [Error] -> RW
RW { names :: Int
names = Int
0, errors :: [Error]
errors = [] }
  (StateT RW Id a -> Id (a, RW)) -> StateT RW Id a -> Id (a, RW)
forall a b. (a -> b) -> a -> b
$ Range -> ReaderT Range (StateT RW Id) a -> StateT RW Id a
forall i (m :: * -> *) a. i -> ReaderT i m a -> m a
runReaderT (Position -> Position -> String -> Range
Range Position
start Position
start String
"")    -- hm
  (ReaderT Range (StateT RW Id) a -> StateT RW Id a)
-> ReaderT Range (StateT RW Id) a -> StateT RW Id a
forall a b. (a -> b) -> a -> b
$ NoPatM a -> ReaderT Range (StateT RW Id) a
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 (PName -> Doc
forall a. PP a => a -> Doc
pp PName
x)
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat ((Located (Schema PName) -> Doc)
-> [Located (Schema PName)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Located (Schema PName) -> Doc
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
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> Range
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 (PName -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> PName
forall a. Located a -> a
thing Located PName
x) Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> Schema PName -> 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
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> Range
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 (Pragma -> Doc
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 (PName -> Doc
forall a. PP a => a -> Doc
pp PName
n)
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat ((Range -> Doc) -> [Range] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Range -> Doc
forall a. PP a => a -> Doc
pp [Range]
locs))

      FixityNoBind Located PName
n ->
        String -> Doc
text String
"At" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> Range
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
<+>
         PName -> Doc
forall a. PP a => a -> Doc
pp (Located PName -> PName
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
<+> PName -> Doc
forall a. PP a => a -> Doc
pp PName
n
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat ((Range -> Doc) -> [Range] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Range -> Doc
forall a. PP a => a -> Doc
pp [Range]
locs))