-- |
-- 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, fixities,
-- and pragmas with the names to which they belong.

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BlockArguments #-}
module Cryptol.Parser.NoPat (RemovePatterns(..),Error(..)) where

import Cryptol.Parser.AST
import Cryptol.Parser.Position(Range(..),emptyRange,start,at)
import Cryptol.Parser.Names (namesP)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.RecordMap

import           MonadLib hiding (mapM)
import           Data.Maybe(maybeToList)
import qualified Data.Map as Map
import           Data.Text (Text)

import GHC.Generics (Generic)
import Control.DeepSeq

class RemovePatterns t where
  -- | 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 = forall a. NoPatM a -> (a, [Error])
runNoPatM (Program PName -> NoPatM (Program PName)
noPatProg Program PName
p)

instance RemovePatterns (Expr PName) where
  removePatterns :: Expr PName -> (Expr PName, [Error])
removePatterns Expr PName
e = forall a. NoPatM a -> (a, [Error])
runNoPatM (Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e)

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

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

instance RemovePatterns (NestedModule PName) where
  removePatterns :: NestedModule PName -> (NestedModule PName, [Error])
removePatterns (NestedModule ModuleG PName PName
m) = (forall name. ModuleG name name -> NestedModule name
NestedModule ModuleG PName PName
m1,[Error]
errs)
    where (ModuleG PName PName
m1,[Error]
errs) = forall t. RemovePatterns t => t -> (t, [Error])
removePatterns ModuleG PName PName
m

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

sel :: Pattern PName -> PName -> Selector -> Bind PName
sel :: Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
p PName
x Selector
s = let (Located PName
a,[Type PName]
ts) = Pattern PName -> (Located PName, [Type PName])
splitSimpleP Pattern PName
p
            in Located PName -> Expr PName -> Bind PName
simpleBind Located PName
a (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall n. Expr n -> Type n -> Expr n
ETyped (forall n. Expr n -> Selector -> Expr n
ESel (forall n. n -> Expr n
EVar PName
x) Selector
s) [Type PName]
ts)

-- | 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. Located n -> Pattern n
PVar Located PName
x, [])

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

    PTuple [Pattern PName]
ps ->
      do ([Pattern PName]
as,[[Bind PName]]
dss) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat [Pattern PName]
ps
         PName
x <- NoPatM PName
newName
         Range
r <- NoPatM Range
getRange
         let len :: Int
len      = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern PName]
ps
             ty :: Type n
ty       = forall n. [Type n] -> Type n
TTuple (forall a. Int -> a -> [a]
replicate Int
len forall n. Type n
TWild)
             getN :: Pattern PName -> Int -> Bind PName
getN Pattern PName
a Int
n = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a PName
x (Int -> Maybe Int -> Selector
TupleSel Int
n (forall a. a -> Maybe a
Just Int
len))
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x forall n. Type n
ty, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PName -> Int -> Bind PName
getN [Pattern PName]
as [Int
0..] forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bind PName]]
dss)

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

    PList [Pattern PName]
ps ->
      do ([Pattern PName]
as,[[Bind PName]]
dss) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat [Pattern PName]
ps
         PName
x <- NoPatM PName
newName
         Range
r <- NoPatM Range
getRange
         let len :: Int
len      = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern PName]
ps
             ty :: Type n
ty       = forall n. Type n -> Type n -> Type n
TSeq (forall n. Integer -> Type n
TNum (forall a. Integral a => a -> Integer
toInteger Int
len)) forall n. Type n
TWild
             getN :: Pattern PName -> Int -> Bind PName
getN Pattern PName
a Int
n = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a PName
x (Int -> Maybe Int -> Selector
ListSel Int
n (forall a. a -> Maybe a
Just Int
len))
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x forall n. Type n
ty, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PName -> Int -> Bind PName
getN [Pattern PName]
as [Int
0..] forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bind PName]]
dss)

    PRecord Rec (Pattern PName)
fs ->
      do let ([Ident]
shape, [(Range, Pattern PName)]
els) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. RecordMap a b -> [(a, b)]
canonicalFields Rec (Pattern PName)
fs)
         ([Pattern PName]
as,[[Bind PName]]
dss) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Range, Pattern PName)]
els
         PName
x <- NoPatM PName
newName
         Range
r <- NoPatM Range
getRange
         let ty :: Type n
ty           = forall n. Rec (Type n) -> Type n
TRecord (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Range
rng,Pattern PName
_) -> (Range
rng,forall n. Type n
TWild)) Rec (Pattern PName)
fs)
             getN :: Pattern PName -> Ident -> Bind PName
getN Pattern PName
a Ident
n     = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a PName
x (Ident -> Maybe [Ident] -> Selector
RecordSel Ident
n (forall a. a -> Maybe a
Just [Ident]
shape))
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Type n -> Pattern n
pTy Range
r PName
x forall n. Type n
ty, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PName -> Ident -> Bind PName
getN [Pattern PName]
as [Ident]
shape forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bind PName]]
dss)

    PTyped Pattern PName
p Type PName
t ->
      do (Pattern PName
a,[Bind PName]
ds) <- Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. Pattern n -> Type n -> Pattern n
PTyped Pattern PName
a Type PName
t, [Bind PName]
ds)

    -- 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 (forall a. Range -> a -> Located a
Located Range
r PName
tmp) (forall n. Expr n -> Expr n
ESplit (forall n. n -> Expr n
EVar PName
x))
             b1 :: Bind PName
b1   = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a1 PName
tmp (Int -> Maybe Int -> Selector
TupleSel Int
0 (forall a. a -> Maybe a
Just Int
2))
             b2 :: Bind PName
b2   = Pattern PName -> PName -> Selector -> Bind PName
sel Pattern PName
a2 PName
tmp (Int -> Maybe Int -> Selector
TupleSel Int
1 (forall a. a -> Maybe a
Just Int
2))
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall {n}. Range -> n -> Pattern n
pVar Range
r PName
x, Bind PName
bTmp forall a. a -> [a] -> [a]
: Bind PName
b1 forall a. a -> [a] -> [a]
: Bind PName
b2 forall a. a -> [a] -> [a]
: [Bind PName]
ds1 forall a. [a] -> [a] -> [a]
++ [Bind PName]
ds2)

    PLocated Pattern PName
p Range
r1 -> forall a. Range -> NoPatM a -> NoPatM a
inRange Range
r1 (Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p)

  where
  pVar :: Range -> n -> Pattern n
pVar Range
r n
x   = forall n. Located n -> Pattern n
PVar (forall a. Range -> a -> Located a
Located Range
r n
x)
  pTy :: Range -> n -> Type n -> Pattern n
pTy  Range
r n
x Type n
t = forall n. Pattern n -> Type n -> Pattern n
PTyped (forall n. Located n -> Pattern n
PVar (forall a. Range -> a -> Located a
Located Range
r n
x)) Type n
t


splitSimpleP :: Pattern PName -> (Located PName, [Type PName])
splitSimpleP :: Pattern PName -> (Located PName, [Type PName])
splitSimpleP (PVar Located PName
x)     = (Located PName
x, [])
splitSimpleP (PTyped Pattern PName
p Type PName
t) = let (Located PName
x,[Type PName]
ts) = Pattern PName -> (Located PName, [Type PName])
splitSimpleP Pattern PName
p
                            in (Located PName
x, Type PName
tforall a. a -> [a] -> [a]
:[Type PName]
ts)
splitSimpleP Pattern PName
p            = forall a. HasCallStack => String -> [String] -> a
panic String
"splitSimpleP"
                                  [ String
"Non-simple pattern", forall a. Show a => a -> String
show Pattern PName
p ]

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

noPatE :: Expr PName -> NoPatM (Expr PName)
noPatE :: Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
expr =
  case Expr PName
expr of
    EVar {}       -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    ELit {}       -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    EGenerate Expr PName
e   -> forall n. Expr n -> Expr n
EGenerate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
    ETuple [Expr PName]
es     -> forall n. [Expr n] -> Expr n
ETuple  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr PName -> NoPatM (Expr PName)
noPatE [Expr PName]
es
    ERecord Rec (Expr PName)
es    -> forall n. Rec (Expr n) -> Expr n
ERecord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr PName -> NoPatM (Expr PName)
noPatE) Rec (Expr PName)
es
    ESel Expr PName
e Selector
s      -> forall n. Expr n -> Selector -> Expr n
ESel    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Selector
s
    EUpd Maybe (Expr PName)
mb [UpdField PName]
fs    -> forall n. Maybe (Expr n) -> [UpdField n] -> Expr n
EUpd    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr PName -> NoPatM (Expr PName)
noPatE Maybe (Expr PName)
mb forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UpdField PName -> NoPatM (UpdField PName)
noPatUF [UpdField PName]
fs
    EList [Expr PName]
es      -> forall n. [Expr n] -> Expr n
EList   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr PName -> NoPatM (Expr PName)
noPatE [Expr PName]
es
    EFromTo {}    -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    EFromToBy {}  -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    EFromToDownBy {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    EFromToLessThan{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    EInfFrom Expr PName
e Maybe (Expr PName)
e' -> forall n. Expr n -> Maybe (Expr n) -> Expr n
EInfFrom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr PName -> NoPatM (Expr PName)
noPatE Maybe (Expr PName)
e'
    EComp Expr PName
e [[Match PName]]
mss   -> forall n. Expr n -> [[Match n]] -> Expr n
EComp  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Match PName] -> NoPatM [Match PName]
noPatArm [[Match PName]]
mss
    EApp Expr PName
e1 Expr PName
e2    -> forall n. Expr n -> Expr n -> Expr n
EApp   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e2
    EAppT Expr PName
e [TypeInst PName]
ts    -> forall n. Expr n -> [TypeInst n] -> Expr n
EAppT  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return [TypeInst PName]
ts
    EIf Expr PName
e1 Expr PName
e2 Expr PName
e3  -> forall n. Expr n -> Expr n -> Expr n -> Expr n
EIf    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e3
    EWhere Expr PName
e [Decl PName]
ds   -> forall n. Expr n -> [Decl n] -> Expr n
EWhere forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Decl PName] -> NoPatM [Decl PName]
noPatDs [Decl PName]
ds
    ETyped Expr PName
e Type PName
t    -> forall n. Expr n -> Type n -> Expr n
ETyped forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Type PName
t
    ETypeVal {}   -> forall (m :: * -> *) a. Monad m => a -> m a
return Expr PName
expr
    EFun FunDesc PName
desc [Pattern PName]
ps Expr PName
e -> Maybe PName
-> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun (forall n. FunDesc n -> Maybe n
funDescrName FunDesc PName
desc) (forall n. FunDesc n -> Int
funDescrArgOffset FunDesc PName
desc) [Pattern PName]
ps Expr PName
e
    ELocated Expr PName
e Range
r1 -> forall n. Expr n -> Range -> Expr n
ELocated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Range -> NoPatM a -> NoPatM a
inRange Range
r1 (Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return Range
r1

    ESplit Expr PName
e      -> forall n. Expr n -> Expr n
ESplit  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
    EParens Expr PName
e     -> forall n. Expr n -> Expr n
EParens forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
    EInfix Expr PName
x Located PName
y Fixity
f Expr PName
z-> forall n. Expr n -> Located n -> Fixity -> Expr n -> Expr n
EInfix  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Located PName
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Fixity
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
z
    EPrefix PrefixOp
op Expr PName
e  -> forall n. PrefixOp -> Expr n -> Expr n
EPrefix PrefixOp
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e


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

-- Desugar lambdas with multiple patterns into a sequence of
-- lambdas with a single, simple pattern each.  Bindings required
-- to simplify patterns are placed inside "where" blocks that are
-- interspersed into the lambdas to ensure that the lexical
-- structure is reliable, with names on the right shadowing names
-- on the left.
noPatFun :: Maybe PName -> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun :: Maybe PName
-> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun Maybe PName
_   Int
_      []     Expr PName
e = Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
noPatFun Maybe PName
mnm Int
offset (Pattern PName
p:[Pattern PName]
ps) Expr PName
e =
  do (Pattern PName
p',[Bind PName]
ds) <- Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p
     Expr PName
e' <- Maybe PName
-> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun Maybe PName
mnm (Int
offsetforall a. Num a => a -> a -> a
+Int
1) [Pattern PName]
ps Expr PName
e
     let body :: Expr PName
body = case [Bind PName]
ds of
                  [] -> Expr PName
e'
                  [Bind PName]
_  -> forall n. Expr n -> [Decl n] -> Expr n
EWhere Expr PName
e' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall name. Bind name -> Decl name
DBind (forall a. [a] -> [a]
reverse [Bind PName]
ds)
                           --                  ^
                           -- This reverse isn't strictly necessary, but yields more sensible
                           -- variable ordering results from type inference.  I'm not entirely
                           -- sure why.
     let desc :: FunDesc PName
desc = forall n. Maybe n -> Int -> FunDesc n
FunDesc Maybe PName
mnm Int
offset
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun FunDesc PName
desc [Pattern PName
p'] Expr PName
body)

noPatArm :: [Match PName] -> NoPatM [Match PName]
noPatArm :: [Match PName] -> NoPatM [Match PName]
noPatArm [Match PName]
ms = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Match PName -> NoPatM [Match PName]
noPatM [Match PName]
ms

noPatM :: Match PName -> NoPatM [Match PName]
noPatM :: Match PName -> NoPatM [Match PName]
noPatM (Match Pattern PName
p Expr PName
e) =
  do (Pattern PName
x,[Bind PName]
bs) <- Pattern PName -> NoPatM (Pattern PName, [Bind PName])
noPat Pattern PName
p
     Expr PName
e1     <- Expr PName -> NoPatM (Expr PName)
noPatE Expr PName
e
     forall (m :: * -> *) a. Monad m => a -> m a
return (forall name. Pattern name -> Expr name -> Match name
Match Pattern PName
x Expr PName
e1 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall name. Bind name -> Match name
MatchLet [Bind PName]
bs)
noPatM (MatchLet Bind PName
b) = (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name. Bind name -> Match name
MatchLet) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bind PName -> NoPatM (Bind PName)
noMatchB Bind PName
b

noMatchB :: Bind PName -> NoPatM (Bind PName)
noMatchB :: Bind PName -> NoPatM (Bind PName)
noMatchB Bind PName
b =
  case forall a. Located a -> a
thing (forall name. Bind name -> Located (BindDef name)
bDef Bind PName
b) of

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

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

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

    DPropGuards [PropGuardCase PName]
guards ->
      do let nm :: PName
nm = forall a. Located a -> a
thing (forall name. Bind name -> Located name
bName Bind PName
b)
             ps :: [Pattern PName]
ps = forall name. Bind name -> [Pattern name]
bParams Bind PName
b
         [PropGuardCase PName]
gs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PName
-> [Pattern PName]
-> PropGuardCase PName
-> NoPatM (PropGuardCase PName)
noPatPropGuardCase PName
nm [Pattern PName]
ps) [PropGuardCase PName]
guards
         forall (f :: * -> *) a. Applicative f => a -> f a
pure Bind PName
b { bParams :: [Pattern PName]
bParams = [], bDef :: Located (BindDef PName)
bDef = forall name. [PropGuardCase name] -> BindDef name
DPropGuards [PropGuardCase PName]
gs forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall name. Bind name -> Located (BindDef name)
bDef Bind PName
b }

noPatPropGuardCase ::
  PName ->
  [Pattern PName] ->
  PropGuardCase PName -> NoPatM (PropGuardCase PName)
noPatPropGuardCase :: PName
-> [Pattern PName]
-> PropGuardCase PName
-> NoPatM (PropGuardCase PName)
noPatPropGuardCase PName
f [Pattern PName]
xs PropGuardCase PName
pc =
  do Expr PName
e <- Maybe PName
-> Int -> [Pattern PName] -> Expr PName -> NoPatM (Expr PName)
noPatFun (forall a. a -> Maybe a
Just PName
f) Int
0 [Pattern PName]
xs (forall name. PropGuardCase name -> Expr name
pgcExpr PropGuardCase PName
pc)
     forall (f :: * -> *) a. Applicative f => a -> f a
pure PropGuardCase PName
pc { pgcExpr :: Expr PName
pgcExpr = Expr PName
e }

noMatchD :: Decl PName -> NoPatM [Decl PName]
noMatchD :: Decl PName -> NoPatM [Decl PName]
noMatchD Decl PName
decl =
  case Decl PName
decl of
    DSignature {}   -> forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
    DPragma {}      -> forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]
    DFixity{}       -> forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PName
decl]

    DBind Bind PName
b         -> do Bind PName
b1 <- Bind PName -> NoPatM (Bind PName)
noMatchB Bind PName
b
                          forall (m :: * -> *) a. Monad m => a -> m a
return [forall name. Bind name -> Decl name
DBind Bind PName
b1]
    DRec {}         -> forall a. HasCallStack => String -> [String] -> a
panic String
"noMatchD" [ String
"DRec" ]

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

    DLocated Decl PName
d Range
r1   -> do [Decl PName]
bs <- forall a. Range -> NoPatM a -> NoPatM a
inRange Range
r1 forall a b. (a -> b) -> a -> b
$ Decl PName -> NoPatM [Decl PName]
noMatchD Decl PName
d
                          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall name. Decl name -> Range -> Decl name
`DLocated` Range
r1) [Decl PName]
bs

noPatDs :: [Decl PName] -> NoPatM [Decl PName]
noPatDs :: [Decl PName] -> NoPatM [Decl PName]
noPatDs [Decl PName]
ds =
  do [Decl PName]
ds1 <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PName -> NoPatM [Decl PName]
noMatchD [Decl PName]
ds
     let fixes :: Map PName [Located Fixity]
fixes = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located Fixity])]
toFixity [Decl PName]
ds1
         amap :: AnnotMap
amap = AnnotMap
           { annPragmas :: Map PName [Located Pragma]
annPragmas = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located Pragma])]
toPragma [Decl PName]
ds1
           , annSigs :: Map PName [Located (Schema PName)]
annSigs    = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located (Schema PName)])]
toSig [Decl PName]
ds1
           , annValueFs :: Map PName [Located Fixity]
annValueFs = Map PName [Located Fixity]
fixes
           , annTypeFs :: Map PName [Located Fixity]
annTypeFs  = Map PName [Located Fixity]
fixes
           , annDocs :: Map PName [Located Text]
annDocs    = forall k a. Map k a
Map.empty
           }

     ([Decl PName]
ds2, AnnotMap { Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annTypeFs :: Map PName [Located Fixity]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: AnnotMap -> Map PName [Located Text]
annTypeFs :: AnnotMap -> Map PName [Located Fixity]
annValueFs :: AnnotMap -> Map PName [Located Fixity]
annSigs :: AnnotMap -> Map PName [Located (Schema PName)]
annPragmas :: AnnotMap -> Map PName [Located Pragma]
.. }) <- forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT AnnotMap
amap (Annotates [Decl PName]
annotDs [Decl PName]
ds1)

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

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

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

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



noPatTopDs :: [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs :: [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs [TopDecl PName]
tds =
  do [TopDecl PName]
desugared <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TopDecl PName -> NoPatM [TopDecl PName]
desugar [TopDecl PName]
tds

     let allDecls :: [Decl PName]
allDecls  = forall a b. (a -> b) -> [a] -> [b]
map forall a. TopLevel a -> a
tlValue (forall {name}. [TopDecl name] -> [TopLevel (Decl name)]
decls [TopDecl PName]
desugared)
         fixes :: Map PName [Located Fixity]
fixes     = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located Fixity])]
toFixity [Decl PName]
allDecls

     let ann :: AnnotMap
ann = AnnotMap
           { annPragmas :: Map PName [Located Pragma]
annPragmas = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located Pragma])]
toPragma [Decl PName]
allDecls
           , annSigs :: Map PName [Located (Schema PName)]
annSigs    = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl PName -> [(PName, [Located (Schema PName)])]
toSig    [Decl PName]
allDecls
           , annValueFs :: Map PName [Located Fixity]
annValueFs = Map PName [Located Fixity]
fixes
           , annTypeFs :: Map PName [Located Fixity]
annTypeFs  = Map PName [Located Fixity]
fixes
           , annDocs :: Map PName [Located Text]
annDocs    = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TopLevel (Decl PName) -> [(PName, [Located Text])]
toDocs forall a b. (a -> b) -> a -> b
$ forall {name}. [TopDecl name] -> [TopLevel (Decl name)]
decls [TopDecl PName]
tds
          }

     ([TopDecl PName]
tds', AnnotMap { Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annTypeFs :: Map PName [Located Fixity]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: AnnotMap -> Map PName [Located Text]
annTypeFs :: AnnotMap -> Map PName [Located Fixity]
annValueFs :: AnnotMap -> Map PName [Located Fixity]
annSigs :: AnnotMap -> Map PName [Located (Schema PName)]
annPragmas :: AnnotMap -> Map PName [Located Pragma]
.. }) <- forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT AnnotMap
ann (Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
desugared)

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

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

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

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

  where
  decls :: [TopDecl name] -> [TopLevel (Decl name)]
decls [TopDecl name]
xs = [ TopLevel (Decl name)
d | Decl TopLevel (Decl name)
d <- [TopDecl name]
xs ]

  desugar :: TopDecl PName -> NoPatM [TopDecl PName]
desugar TopDecl PName
d =
    case TopDecl PName
d of
      Decl TopLevel (Decl PName)
tl -> do [Decl PName]
ds <- Decl PName -> NoPatM [Decl PName]
noMatchD (forall a. TopLevel a -> a
tlValue TopLevel (Decl PName)
tl)
                    forall (m :: * -> *) a. Monad m => a -> m a
return [ forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel (Decl PName)
tl { tlValue :: Decl PName
tlValue = Decl PName
d1 } | Decl PName
d1 <- [Decl PName]
ds ]
      TopDecl PName
x      -> forall (m :: * -> *) a. Monad m => a -> m a
return [TopDecl PName
x]


noPatProg :: Program PName -> NoPatM (Program PName)
noPatProg :: Program PName -> NoPatM (Program PName)
noPatProg (Program [TopDecl PName]
topDs) = forall name. [TopDecl name] -> Program name
Program forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs [TopDecl PName]
topDs

noPatModule :: ModuleG mname PName -> NoPatM (ModuleG mname PName)
noPatModule :: forall mname. ModuleG mname PName -> NoPatM (ModuleG mname PName)
noPatModule ModuleG mname PName
m =
  do ModuleDefinition PName
def <-
       case forall mname name. ModuleG mname name -> ModuleDefinition name
mDef ModuleG mname PName
m of
         NormalModule [TopDecl PName]
ds -> forall name. [TopDecl name] -> ModuleDefinition name
NormalModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TopDecl PName] -> NoPatM [TopDecl PName]
noPatTopDs [TopDecl PName]
ds
         FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as ModuleInstance PName
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name.
Located (ImpName name)
-> ModuleInstanceArgs name
-> ModuleInstance name
-> ModuleDefinition name
FunctorInstance Located (ImpName PName)
f ModuleInstanceArgs PName
as ModuleInstance PName
i)
         InterfaceModule Signature PName
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall name. Signature name -> ModuleDefinition name
InterfaceModule Signature PName
s)
     forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleG mname PName
m { mDef :: ModuleDefinition PName
mDef = ModuleDefinition PName
def }

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

data AnnotMap = AnnotMap
  { AnnotMap -> Map PName [Located Pragma]
annPragmas  :: Map.Map PName [Located  Pragma       ]
  , AnnotMap -> Map PName [Located (Schema PName)]
annSigs     :: Map.Map PName [Located (Schema PName)]
  , AnnotMap -> Map PName [Located Fixity]
annValueFs  :: Map.Map PName [Located  Fixity       ]
  , AnnotMap -> Map PName [Located Fixity]
annTypeFs   :: Map.Map PName [Located  Fixity       ]
  , AnnotMap -> Map PName [Located Text]
annDocs     :: Map.Map PName [Located  Text         ]
  }

type Annotates a = a -> StateT AnnotMap NoPatM a

-- | 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 <- forall i (m :: * -> *) a. ExceptionT i m a -> m (Either i a)
runExceptionT (Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD (forall a. TopLevel a -> a
tlValue TopLevel (Decl PName)
d1))
             case Either () (Decl PName)
ignore of
               Left ()
_   -> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds
               Right Decl PName
d2 -> (forall name. TopLevel (Decl name) -> TopDecl name
Decl (TopLevel (Decl PName)
d1 { tlValue :: Decl PName
tlValue = Decl PName
d2 }) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds

        DPrimType TopLevel (PrimType PName)
tl ->
          do PrimType PName
pt <- Annotates (PrimType PName)
annotPrimType (forall a. TopLevel a -> a
tlValue TopLevel (PrimType PName)
tl)
             let d1 :: TopDecl PName
d1 = forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel (PrimType PName)
tl { tlValue :: PrimType PName
tlValue = PrimType PName
pt }
             (TopDecl PName
d1 forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds

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

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

        DModule TopLevel (NestedModule PName)
m ->
          case forall t. RemovePatterns t => t -> (t, [Error])
removePatterns (forall a. TopLevel a -> a
tlValue TopLevel (NestedModule PName)
m) of
            (NestedModule PName
m1,[Error]
errs) -> do forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Error -> NoPatM ()
recordError [Error]
errs)
                            (forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel (NestedModule PName)
m { tlValue :: NestedModule PName
tlValue = NestedModule PName
m1 } forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [TopDecl PName]
annotTopDs [TopDecl PName]
ds

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

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

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


-- | 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 <- forall i (m :: * -> *) a. ExceptionT i m a -> m (Either i a)
runExceptionT (Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD Decl PName
d)
     case Either () (Decl PName)
ignore of
       Left ()   -> Annotates [Decl PName]
annotDs [Decl PName]
ds
       Right Decl PName
d1  -> (Decl PName
d1 forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotates [Decl PName]
annotDs [Decl PName]
ds
annotDs [] = forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | 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       -> forall name. Bind name -> Decl name
DBind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (Annotates (Bind PName)
annotB Bind PName
b)
    DRec {}       -> forall a. HasCallStack => String -> [String] -> a
panic String
"annotD" [ String
"DRec" ]
    DSignature {} -> forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
    DFixity{}     -> forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
    DPragma {}    -> forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
    DPatBind {}   -> forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ()
    DType TySyn PName
tysyn   -> forall name. TySyn name -> Decl name
DType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (Annotates (TySyn PName)
annotTySyn TySyn PName
tysyn)
    DProp PropSyn PName
propsyn -> forall name. PropSyn name -> Decl name
DProp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (Annotates (PropSyn PName)
annotPropSyn PropSyn PName
propsyn)
    DLocated Decl PName
d Range
r  -> (forall name. Decl name -> Range -> Decl name
`DLocated` Range
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decl PName -> ExceptionT () (StateT AnnotMap NoPatM) (Decl PName)
annotD Decl PName
d

-- | 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)
ExportType
bExport :: ExportType
bDoc :: Maybe Text
bMono :: Bool
bPragmas :: [Pragma]
bFixity :: Maybe Fixity
bInfix :: Bool
bSignature :: Maybe (Schema PName)
bDef :: Located (BindDef PName)
bParams :: [Pattern PName]
bName :: Located PName
bExport :: forall name. Bind name -> ExportType
bDoc :: forall name. Bind name -> Maybe Text
bFixity :: forall name. Bind name -> Maybe Fixity
bInfix :: forall name. Bind name -> Bool
bMono :: forall name. Bind name -> Bool
bPragmas :: forall name. Bind name -> [Pragma]
bSignature :: forall name. Bind name -> Maybe (Schema name)
bDef :: forall name. Bind name -> Located (BindDef name)
bParams :: forall name. Bind name -> [Pattern name]
bName :: forall name. Bind name -> Located name
.. } =
  do AnnotMap { Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annTypeFs :: Map PName [Located Fixity]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: AnnotMap -> Map PName [Located Text]
annTypeFs :: AnnotMap -> Map PName [Located Fixity]
annValueFs :: AnnotMap -> Map PName [Located Fixity]
annSigs :: AnnotMap -> Map PName [Located (Schema PName)]
annPragmas :: AnnotMap -> Map PName [Located Pragma]
.. } <- forall (m :: * -> *) i. StateM m i => m i
get
     let name :: PName
name       = forall a. Located a -> a
thing Located PName
bName
         remove :: p -> p -> Maybe a
remove p
_ p
_ = forall a. Maybe a
Nothing
         (Maybe [Located Pragma]
thisPs    , Map PName [Located Pragma]
ps') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located Pragma]
annPragmas
         (Maybe [Located (Schema PName)]
thisSigs  , Map PName [Located (Schema PName)]
ss') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located (Schema PName)]
annSigs
         (Maybe [Located Fixity]
thisFixes , Map PName [Located Fixity]
fs') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located Fixity]
annValueFs
         (Maybe [Located Text]
thisDocs  , Map PName [Located Text]
ds') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located Text]
annDocs
     Maybe (Schema PName)
s <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs PName
name forall a b. (a -> b) -> a -> b
$ forall {a}. Maybe [a] -> [a]
jn Maybe [Located (Schema PName)]
thisSigs
     Maybe Fixity
f <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs PName
name forall a b. (a -> b) -> a -> b
$ forall {a}. Maybe [a] -> [a]
jn Maybe [Located Fixity]
thisFixes
     Maybe Text
d <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PName -> [Located Text] -> NoPatM (Maybe Text)
checkDocs PName
name forall a b. (a -> b) -> a -> b
$ forall {a}. Maybe [a] -> [a]
jn Maybe [Located Text]
thisDocs
     forall (m :: * -> *) i. StateM m i => i -> m ()
set AnnotMap { annPragmas :: Map PName [Located Pragma]
annPragmas = Map PName [Located Pragma]
ps'
                  , annSigs :: Map PName [Located (Schema PName)]
annSigs    = Map PName [Located (Schema PName)]
ss'
                  , annValueFs :: Map PName [Located Fixity]
annValueFs = Map PName [Located Fixity]
fs'
                  , annDocs :: Map PName [Located Text]
annDocs    = Map PName [Located Text]
ds'
                  , Map PName [Located Fixity]
annTypeFs :: Map PName [Located Fixity]
annTypeFs :: Map PName [Located Fixity]
..
                  }
     forall (m :: * -> *) a. Monad m => a -> m a
return Bind { bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
s
                 , bPragmas :: [Pragma]
bPragmas = forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> a
thing (forall {a}. Maybe [a] -> [a]
jn Maybe [Located Pragma]
thisPs) forall a. [a] -> [a] -> [a]
++ [Pragma]
bPragmas
                 , bFixity :: Maybe Fixity
bFixity = Maybe Fixity
f
                 , bDoc :: Maybe Text
bDoc = Maybe Text
d
                 , Bool
[Pattern PName]
Located PName
Located (BindDef PName)
ExportType
bExport :: ExportType
bMono :: Bool
bInfix :: Bool
bDef :: Located (BindDef PName)
bParams :: [Pattern PName]
bName :: Located PName
bExport :: ExportType
bInfix :: Bool
bMono :: Bool
bDef :: Located (BindDef PName)
bParams :: [Pattern PName]
bName :: Located PName
..
                 }
  where jn :: Maybe [a] -> [a]
jn Maybe [a]
x = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. Maybe a -> [a]
maybeToList Maybe [a]
x)

annotTyThing :: PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing :: PName -> StateT AnnotMap NoPatM (Maybe Fixity)
annotTyThing PName
name =
  do AnnotMap { Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annTypeFs :: Map PName [Located Fixity]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: AnnotMap -> Map PName [Located Text]
annTypeFs :: AnnotMap -> Map PName [Located Fixity]
annValueFs :: AnnotMap -> Map PName [Located Fixity]
annSigs :: AnnotMap -> Map PName [Located (Schema PName)]
annPragmas :: AnnotMap -> Map PName [Located Pragma]
.. } <- forall (m :: * -> *) i. StateM m i => m i
get
     let remove :: p -> p -> Maybe a
remove p
_ p
_ = forall a. Maybe a
Nothing
         (Maybe [Located Fixity]
thisFixes, Map PName [Located Fixity]
ts') = forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey forall {p} {p} {a}. p -> p -> Maybe a
remove PName
name Map PName [Located Fixity]
annTypeFs
     Maybe Fixity
f <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs PName
name forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe [Located Fixity]
thisFixes
     forall (m :: * -> *) i. StateM m i => i -> m ()
set AnnotMap { annTypeFs :: Map PName [Located Fixity]
annTypeFs = Map PName [Located Fixity]
ts', Map PName [Located Text]
Map PName [Located Fixity]
Map PName [Located (Schema PName)]
Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
annDocs :: Map PName [Located Text]
annValueFs :: Map PName [Located Fixity]
annSigs :: Map PName [Located (Schema PName)]
annPragmas :: Map PName [Located Pragma]
.. }
     forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Fixity
f


-- | 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 (forall a. Located a -> a
thing Located PName
ln)
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall n.
Located n -> Maybe Fixity -> [TParam n] -> Type n -> TySyn n
TySyn Located PName
ln Maybe Fixity
f [TParam PName]
params Type PName
rhs)

-- | 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 (forall a. Located a -> a
thing Located PName
ln)
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall n.
Located n -> Maybe Fixity -> [TParam n] -> [Prop n] -> PropSyn n
PropSyn Located PName
ln Maybe Fixity
f [TParam PName]
params [Prop PName]
rhs)

-- | 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 (forall a. Located a -> a
thing (forall name. PrimType name -> Located name
primTName PrimType PName
pt))
     forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimType PName
pt { primTFixity :: Maybe Fixity
primTFixity = Maybe Fixity
f }

-- | Check for multiple signatures.
checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs :: PName -> [Located (Schema PName)] -> NoPatM (Maybe (Schema PName))
checkSigs PName
_ []             = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
checkSigs PName
_ [Located (Schema PName)
s]            = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located (Schema PName)
s))
checkSigs PName
f xs :: [Located (Schema PName)]
xs@(Located (Schema PName)
s : Located (Schema PName)
_ : [Located (Schema PName)]
_) = do Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ PName -> [Located (Schema PName)] -> Error
MultipleSignatures PName
f [Located (Schema PName)]
xs
                                forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located (Schema PName)
s))

checkFixs :: PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs :: PName -> [Located Fixity] -> NoPatM (Maybe Fixity)
checkFixs PName
_ []       = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
checkFixs PName
_ [Located Fixity
f]      = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located Fixity
f))
checkFixs PName
f fs :: [Located Fixity]
fs@(Located Fixity
x:[Located Fixity]
_) = do Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ PName -> [Range] -> Error
MultipleFixities PName
f forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> Range
srcRange [Located Fixity]
fs
                          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located Fixity
x))


checkDocs :: PName -> [Located Text] -> NoPatM (Maybe Text)
checkDocs :: PName -> [Located Text] -> NoPatM (Maybe Text)
checkDocs PName
_ []       = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
checkDocs PName
_ [Located Text
d]      = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located Text
d))
checkDocs PName
f ds :: [Located Text]
ds@(Located Text
d:[Located Text]
_) = do Error -> NoPatM ()
recordError forall a b. (a -> b) -> a -> b
$ PName -> [Range] -> Error
MultipleDocs PName
f (forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> Range
srcRange [Located Text]
ds)
                          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a. Located a -> a
thing Located Text
d))


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

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

-- | 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) = [ (forall a. Located a -> a
thing Located PName
n, [forall a. Range -> a -> Located a
Located (forall a. Located a -> Range
srcRange Located PName
n) Fixity
f]) | Located PName
n <- [Located PName]
ns ]
toFixity Decl PName
_              = []

-- | 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 = forall {t} {name}. t -> Decl name -> [(name, [t])]
go Located Text
txt Decl PName
tlValue
  | Bool
otherwise = []
  where
  go :: t -> Decl name -> [(name, [t])]
go t
txt Decl name
decl =
    case Decl name
decl of
      DSignature [Located name]
ns Schema name
_ -> [ (forall a. Located a -> a
thing Located name
n, [t
txt]) | Located name
n <- [Located name]
ns ]
      DFixity Fixity
_ [Located name]
ns    -> [ (forall a. Located a -> a
thing Located name
n, [t
txt]) | Located name
n <- [Located name]
ns ]
      DBind Bind name
b         -> [ (forall a. Located a -> a
thing (forall name. Bind name -> Located name
bName Bind name
b), [t
txt]) ]
      DRec {}         -> forall a. HasCallStack => String -> [String] -> a
panic String
"toDocs" [ String
"DRec" ]
      DLocated Decl name
d Range
_    -> t -> Decl name -> [(name, [t])]
go t
txt Decl name
d
      DPatBind Pattern name
p Expr name
_    -> [ (forall a. Located a -> a
thing Located name
n, [t
txt]) | Located name
n <- forall name. Pattern name -> [Located name]
namesP Pattern name
p ]

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


--------------------------------------------------------------------------------
newtype NoPatM a = M { forall a. NoPatM a -> ReaderT Range (StateT RW Id) a
unM :: ReaderT Range (StateT RW Id) a }

data RW     = RW { RW -> Int
names :: !Int, RW -> [Error]
errors :: [Error] }

data Error  = MultipleSignatures PName [Located (Schema PName)]
            | SignatureNoBind (Located PName) (Schema PName)
            | PragmaNoBind (Located PName) Pragma
            | MultipleFixities PName [Range]
            | FixityNoBind (Located PName)
            | MultipleDocs PName [Range]
              deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show,forall x. Rep Error x -> Error
forall x. Error -> Rep Error x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Error x -> Error
$cfrom :: forall x. Error -> Rep Error x
Generic, Error -> ()
forall a. (a -> ()) -> NFData a
rnf :: Error -> ()
$crnf :: Error -> ()
NFData)

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

-- | Pick a new name, to be used when desugaring patterns.
newName :: NoPatM PName
newName :: NoPatM PName
newName = forall a. ReaderT Range (StateT RW Id) a -> NoPatM a
M forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets forall a b. (a -> b) -> a -> b
$ \RW
s -> let x :: Int
x = RW -> Int
names RW
s
                           in (Pass -> Int -> PName
NewName Pass
NoPat Int
x, RW
s { names :: Int
names = Int
x forall a. Num a => a -> a -> a
+ Int
1 })

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

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

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


runNoPatM :: NoPatM a -> (a, [Error])
runNoPatM :: forall a. NoPatM a -> (a, [Error])
runNoPatM NoPatM a
m
  = forall {a}. (a, RW) -> (a, [Error])
getErrs
  forall a b. (a -> b) -> a -> b
$ forall a. Id a -> a
runId
  forall a b. (a -> b) -> a -> b
$ forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT RW { names :: Int
names = Int
0, errors :: [Error]
errors = [] }
  forall a b. (a -> b) -> a -> b
$ forall i (m :: * -> *) a. i -> ReaderT i m a -> m a
runReaderT (Position -> Position -> String -> Range
Range Position
start Position
start String
"")    -- hm
  forall a b. (a -> b) -> a -> b
$ forall a. NoPatM a -> ReaderT Range (StateT RW Id) a
unM NoPatM a
m
  where getErrs :: (a, RW) -> (a, [Error])
getErrs (a
a,RW
rw) = (a
a, RW -> [Error]
errors RW
rw)

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

instance PP Error where
  ppPrec :: Int -> Error -> Doc
ppPrec Int
_ Error
err =
    case Error
err of
      MultipleSignatures PName
x [Located (Schema PName)]
ss ->
        String -> Doc
text String
"Multiple type signatures for" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (forall a. PP a => a -> Doc
pp PName
x)
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp [Located (Schema PName)]
ss))

      SignatureNoBind Located PName
x Schema PName
s ->
        String -> Doc
text String
"At" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp (forall a. Located a -> Range
srcRange Located PName
x) Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
<+>
        String -> Doc
text String
"Type signature without a matching binding:"
         Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 (forall a. PP a => a -> Doc
pp (forall a. Located a -> a
thing Located PName
x) Doc -> Doc -> Doc
<+> Doc
colon Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Schema PName
s)

      PragmaNoBind Located PName
x Pragma
s ->
        String -> Doc
text String
"At" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp (forall a. Located a -> Range
srcRange Located PName
x) Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
<+>
        String -> Doc
text String
"Pragma without a matching binding:"
         Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 (forall a. PP a => a -> Doc
pp Pragma
s)

      MultipleFixities PName
n [Range]
locs ->
        String -> Doc
text String
"Multiple fixity declarations for" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (forall a. PP a => a -> Doc
pp PName
n)
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp [Range]
locs))

      FixityNoBind Located PName
n ->
        String -> Doc
text String
"At" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp (forall a. Located a -> Range
srcRange Located PName
n) Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
<+>
        String -> Doc
text String
"Fixity declaration without a matching binding for:" Doc -> Doc -> Doc
<+>
         forall a. PP a => a -> Doc
pp (forall a. Located a -> a
thing Located PName
n)

      MultipleDocs PName
n [Range]
locs ->
        String -> Doc
text String
"Multiple documentation blocks given for:" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp PName
n
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp [Range]
locs))