-- |
-- Module      :  Cryptol.Parser.ParserUtils
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE Safe #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Cryptol.Parser.ParserUtils where

import Data.Maybe(fromMaybe)
import Data.Bits(testBit,setBit)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Control.Monad(liftM,ap,unless,guard)
import qualified Control.Monad.Fail as Fail
import           Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Map as Map
import Text.Read(readMaybe)

import GHC.Generics (Generic)
import Control.DeepSeq

import Prelude ()
import Prelude.Compat


import Cryptol.Parser.AST
import Cryptol.Parser.Lexer
import Cryptol.Parser.Token(SelectorType(..))
import Cryptol.Parser.Position
import Cryptol.Parser.Utils (translateExprToNumT,widthIdent)
import Cryptol.Utils.Ident(packModName,packIdent,modNameChunks)
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
import Cryptol.Utils.RecordMap


parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString :: Config -> ParseM a -> String -> Either ParseError a
parseString Config
cfg ParseM a
p String
cs = Config -> ParseM a -> Text -> Either ParseError a
forall a. Config -> ParseM a -> Text -> Either ParseError a
parse Config
cfg ParseM a
p (String -> Text
T.pack String
cs)

parse :: Config -> ParseM a -> Text -> Either ParseError a
parse :: Config -> ParseM a -> Text -> Either ParseError a
parse Config
cfg ParseM a
p Text
cs    = case ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP ParseM a
p Config
cfg Position
eofPos S :: Maybe (Located Token) -> [Located Token] -> Int -> S
S { sPrevTok :: Maybe (Located Token)
sPrevTok = Maybe (Located Token)
forall a. Maybe a
Nothing
                                            , sTokens :: [Located Token]
sTokens = [Located Token]
toks
                                            , sNextTyParamNum :: Int
sNextTyParamNum = Int
0
                                            } of
                      Left ParseError
err    -> ParseError -> Either ParseError a
forall a b. a -> Either a b
Left ParseError
err
                      Right (a
a,S
_) -> a -> Either ParseError a
forall a b. b -> Either a b
Right a
a
  where ([Located Token]
toks,Position
eofPos) = Config -> Text -> ([Located Token], Position)
lexer Config
cfg Text
cs


{- The parser is parameterized by the pozition of the final token. -}
newtype ParseM a =
  P { ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP :: Config -> Position -> S -> Either ParseError (a,S) }


lexerP :: (Located Token -> ParseM a) -> ParseM a
lexerP :: (Located Token -> ParseM a) -> ParseM a
lexerP Located Token -> ParseM a
k = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
p S
s ->
  case S -> [Located Token]
sTokens S
s of
    Located Token
t : [Located Token]
_ | Err TokenErr
e <- Token -> TokenT
tokenType Token
it ->
      ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (ParseError -> Either ParseError (a, S))
-> ParseError -> Either ParseError (a, S)
forall a b. (a -> b) -> a -> b
$ Range -> [String] -> ParseError
HappyErrorMsg (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t) ([String] -> ParseError) -> [String] -> ParseError
forall a b. (a -> b) -> a -> b
$
        [case TokenErr
e of
           TokenErr
UnterminatedComment -> String
"unterminated comment"
           TokenErr
UnterminatedString  -> String
"unterminated string"
           TokenErr
UnterminatedChar    -> String
"unterminated character"
           TokenErr
InvalidString       -> String
"invalid string literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    Text -> String
T.unpack (Token -> Text
tokenText Token
it)
           TokenErr
InvalidChar         -> String
"invalid character literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    Text -> String
T.unpack (Token -> Text
tokenText Token
it)
           TokenErr
LexicalError        -> String
"unrecognized character: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    Text -> String
T.unpack (Token -> Text
tokenText Token
it)
           TokenErr
MalformedLiteral    -> String
"malformed literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    Text -> String
T.unpack (Token -> Text
tokenText Token
it)
           TokenErr
MalformedSelector   -> String
"malformed selector: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    Text -> String
T.unpack (Token -> Text
tokenText Token
it)
           InvalidIndentation TokenT
c -> String
"invalid indentation, unmatched " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              case TokenT
c of
                Sym TokenSym
CurlyR    -> String
"{ ... } "
                Sym TokenSym
ParenR    -> String
"( ... )"
                Sym TokenSym
BracketR  -> String
"[ ... ]"
                TokenT
_             -> TokenT -> String
forall a. Show a => a -> String
show TokenT
c -- basically panic
        ]
      where it :: Token
it = Located Token -> Token
forall a. Located a -> a
thing Located Token
t

    Located Token
t : [Located Token]
more -> ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP (Located Token -> ParseM a
k Located Token
t) Config
cfg Position
p S
s { sPrevTok :: Maybe (Located Token)
sPrevTok = Located Token -> Maybe (Located Token)
forall a. a -> Maybe a
Just Located Token
t, sTokens :: [Located Token]
sTokens = [Located Token]
more }
    [] -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (String -> Position -> ParseError
HappyOutOfTokens (Config -> String
cfgSource Config
cfg) Position
p)

data ParseError = HappyError FilePath         {- Name of source file -}
                             (Located Token)  {- Offending token -}
                | HappyErrorMsg Range [String]
                | HappyUnexpected FilePath (Maybe (Located Token)) String
                | HappyOutOfTokens FilePath Position
                  deriving (Int -> ParseError -> String -> String
[ParseError] -> String -> String
ParseError -> String
(Int -> ParseError -> String -> String)
-> (ParseError -> String)
-> ([ParseError] -> String -> String)
-> Show ParseError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ParseError] -> String -> String
$cshowList :: [ParseError] -> String -> String
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> String -> String
$cshowsPrec :: Int -> ParseError -> String -> String
Show, (forall x. ParseError -> Rep ParseError x)
-> (forall x. Rep ParseError x -> ParseError) -> Generic ParseError
forall x. Rep ParseError x -> ParseError
forall x. ParseError -> Rep ParseError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ParseError x -> ParseError
$cfrom :: forall x. ParseError -> Rep ParseError x
Generic, ParseError -> ()
(ParseError -> ()) -> NFData ParseError
forall a. (a -> ()) -> NFData a
rnf :: ParseError -> ()
$crnf :: ParseError -> ()
NFData)

data S = S { S -> Maybe (Located Token)
sPrevTok :: Maybe (Located Token)
           , S -> [Located Token]
sTokens :: [Located Token]
           , S -> Int
sNextTyParamNum :: !Int
             -- ^ Keep track of the type parameters as they appear in the input
           }

ppError :: ParseError -> Doc

ppError :: ParseError -> Doc
ppError (HappyError String
path Located Token
ltok)
  | Err TokenErr
_ <- Token -> TokenT
tokenType Token
tok =
    String -> Doc
text String
"Parse error at" Doc -> Doc -> Doc
<+>
    String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> Doc
<+>
    Token -> Doc
forall a. PP a => a -> Doc
pp Token
tok

  | White TokenW
DocStr <- Token -> TokenT
tokenType Token
tok =
    Doc
"Unexpected documentation (/**) comment at" Doc -> Doc -> Doc
<+>
    String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
$$
    Int -> Doc -> Doc
indent Int
2
      Doc
"Documentation comments need to be followed by something to document."

  | Bool
otherwise =
    String -> Doc
text String
"Parse error at" Doc -> Doc -> Doc
<+>
    String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> Doc
$$
    Int -> Doc -> Doc
indent Int
2 (String -> Doc
text String
"unexpected:" Doc -> Doc -> Doc
<+> Token -> Doc
forall a. PP a => a -> Doc
pp Token
tok)
  where
  pos :: Position
pos = Range -> Position
from (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
ltok)
  tok :: Token
tok = Located Token -> Token
forall a. Located a -> a
thing Located Token
ltok

ppError (HappyOutOfTokens String
path Position
pos) =
  String -> Doc
text String
"Unexpected end of file at:" Doc -> Doc -> Doc
<+>
    String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos

ppError (HappyErrorMsg Range
p [String]
xs)  = String -> Doc
text String
"Parse error at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp Range
p Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
indent Int
2 ([Doc] -> Doc
vcat ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
xs))

ppError (HappyUnexpected String
path Maybe (Located Token)
ltok String
e) =
  Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
   [ String -> Doc
text String
"Parse error at" Doc -> Doc -> Doc
<+> String -> Doc
text String
path Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':' Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp Position
pos Doc -> Doc -> Doc
<.> Doc
comma ]
   [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc]
unexp
   [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc
"expected:" Doc -> Doc -> Doc
<+> String -> Doc
text String
e]
  where
  ([Doc]
unexp,Position
pos) =
    case Maybe (Located Token)
ltok of
      Maybe (Located Token)
Nothing -> ( [] ,Position
start)
      Just Located Token
t  -> ( [Doc
"unexpected:" Doc -> Doc -> Doc
<+> String -> Doc
text (Text -> String
T.unpack (Token -> Text
tokenText (Located Token -> Token
forall a. Located a -> a
thing Located Token
t)))]
                 , Range -> Position
from (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t)
                 )

instance Functor ParseM where
  fmap :: (a -> b) -> ParseM a -> ParseM b
fmap = (a -> b) -> ParseM a -> ParseM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative ParseM where
  pure :: a -> ParseM a
pure a
a = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\Config
_ Position
_ S
s -> (a, S) -> Either ParseError (a, S)
forall a b. b -> Either a b
Right (a
a,S
s))
  <*> :: ParseM (a -> b) -> ParseM a -> ParseM b
(<*>) = ParseM (a -> b) -> ParseM a -> ParseM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad ParseM where
  return :: a -> ParseM a
return    = a -> ParseM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ParseM a
m >>= :: ParseM a -> (a -> ParseM b) -> ParseM b
>>= a -> ParseM b
k   = (Config -> Position -> S -> Either ParseError (b, S)) -> ParseM b
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P (\Config
cfg Position
p S
s1 -> case ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP ParseM a
m Config
cfg Position
p S
s1 of
                            Left ParseError
e       -> ParseError -> Either ParseError (b, S)
forall a b. a -> Either a b
Left ParseError
e
                            Right (a
a,S
s2) -> ParseM b -> Config -> Position -> S -> Either ParseError (b, S)
forall a.
ParseM a -> Config -> Position -> S -> Either ParseError (a, S)
unP (a -> ParseM b
k a
a) Config
cfg Position
p S
s2)

instance Fail.MonadFail ParseM where
  fail :: String -> ParseM a
fail String
s    = String -> [String] -> ParseM a
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] fail" [String
s]

happyError :: ParseM a
happyError :: ParseM a
happyError = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
_ S
s ->
  case S -> Maybe (Located Token)
sPrevTok S
s of
    Just Located Token
t  -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (String -> Located Token -> ParseError
HappyError (Config -> String
cfgSource Config
cfg) Located Token
t)
    Maybe (Located Token)
Nothing ->
      ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> [String] -> ParseError
HappyErrorMsg Range
emptyRange [String
"Parse error at the beginning of the file"])

errorMessage :: Range -> [String] -> ParseM a
errorMessage :: Range -> [String] -> ParseM a
errorMessage Range
r [String]
xs = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
_ -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> [String] -> ParseError
HappyErrorMsg Range
r [String]
xs)

customError :: String -> Located Token -> ParseM a
customError :: String -> Located Token -> ParseM a
customError String
x Located Token
t = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
_ -> ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (Range -> [String] -> ParseError
HappyErrorMsg (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t) [String
x])

expected :: String -> ParseM a
expected :: String -> ParseM a
expected String
x = (Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a)
-> (Config -> Position -> S -> Either ParseError (a, S))
-> ParseM a
forall a b. (a -> b) -> a -> b
$ \Config
cfg Position
_ S
s ->
                    ParseError -> Either ParseError (a, S)
forall a b. a -> Either a b
Left (String -> Maybe (Located Token) -> String -> ParseError
HappyUnexpected (Config -> String
cfgSource Config
cfg) (S -> Maybe (Located Token)
sPrevTok S
s) String
x)









mkModName :: [Text] -> ModName
mkModName :: [Text] -> ModName
mkModName = [Text] -> ModName
packModName

-- Note that type variables are not resolved at this point: they are tcons.
mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName
mkSchema :: [TParam PName] -> [Prop PName] -> Type PName -> Schema PName
mkSchema [TParam PName]
xs [Prop PName]
ps Type PName
t = [TParam PName]
-> [Prop PName] -> Type PName -> Maybe Range -> Schema PName
forall n.
[TParam n] -> [Prop n] -> Type n -> Maybe Range -> Schema n
Forall [TParam PName]
xs [Prop PName]
ps Type PName
t Maybe Range
forall a. Maybe a
Nothing

getName :: Located Token -> PName
getName :: Located Token -> PName
getName Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
              Token (Ident [] Text
x) Text
_ -> Ident -> PName
mkUnqual (Text -> Ident
mkIdent Text
x)
              Token
_ -> String -> [String] -> PName
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] getName" [String
"not an Ident:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]

getNum :: Located Token -> Integer
getNum :: Located Token -> Integer
getNum Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
             Token (Num Integer
x Int
_ Int
_) Text
_ -> Integer
x
             Token (ChrLit Char
x) Text
_  -> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x)
             Token
_ -> String -> [String] -> Integer
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] getNum" [String
"not a number:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]

getChr :: Located Token -> Char
getChr :: Located Token -> Char
getChr Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
             Token (ChrLit Char
x) Text
_  -> Char
x
             Token
_ -> String -> [String] -> Char
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] getChr" [String
"not a char:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]

getStr :: Located Token -> String
getStr :: Located Token -> String
getStr Located Token
l = case Located Token -> Token
forall a. Located a -> a
thing Located Token
l of
             Token (StrLit String
x) Text
_ -> String
x
             Token
_ -> String -> [String] -> String
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] getStr" [String
"not a string:", Located Token -> String
forall a. Show a => a -> String
show Located Token
l]

numLit :: Token -> Expr PName
numLit :: Token -> Expr PName
numLit Token { tokenText :: Token -> Text
tokenText = Text
txt, tokenType :: Token -> TokenT
tokenType = Num Integer
x Int
base Int
digs }
  | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2   = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
BinLit Text
txt Int
digs)
  | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8   = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
OctLit Text
txt Int
digs)
  | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10  = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> NumInfo
DecLit Text
txt)
  | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16  = Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
x (Text -> Int -> NumInfo
HexLit Text
txt Int
digs)

numLit Token
x = String -> [String] -> Expr PName
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] numLit" [String
"invalid numeric literal", Token -> String
forall a. Show a => a -> String
show Token
x]

fracLit :: Token -> Expr PName
fracLit :: Token -> Expr PName
fracLit Token
tok =
  case Token -> TokenT
tokenType Token
tok of
    Frac Rational
x Int
base
      | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2   -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
BinFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
      | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8   -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
OctFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
      | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10  -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
DecFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
      | Int
base Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16  -> Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Rational -> FracInfo -> Literal
ECFrac Rational
x (FracInfo -> Literal) -> FracInfo -> Literal
forall a b. (a -> b) -> a -> b
$ Text -> FracInfo
HexFrac (Text -> FracInfo) -> Text -> FracInfo
forall a b. (a -> b) -> a -> b
$ Token -> Text
tokenText Token
tok
    TokenT
_ -> String -> [String] -> Expr PName
forall a. HasCallStack => String -> [String] -> a
panic String
"[Parser] fracLit" [ String
"Invalid fraction", Token -> String
forall a. Show a => a -> String
show Token
tok ]


intVal :: Located Token -> ParseM Integer
intVal :: Located Token -> ParseM Integer
intVal Located Token
tok =
  case Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
tok) of
    Num Integer
x Int
_ Int
_ -> Integer -> ParseM Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x
    TokenT
_         -> Range -> [String] -> ParseM Integer
forall a. Range -> [String] -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
tok) [String
"Expected an integer"]

mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity Assoc
assoc Located Token
tok [LPName]
qns =
  do Integer
l <- Located Token -> ParseM Integer
intVal Located Token
tok
     Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1 Bool -> Bool -> Bool
&& Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
100)
          (Range -> [String] -> ParseM ()
forall a. Range -> [String] -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
tok) [String
"Fixity levels must be between 1 and 100"])
     Decl PName -> ParseM (Decl PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Fixity -> [LPName] -> Decl PName
forall name. Fixity -> [Located name] -> Decl name
DFixity (Assoc -> Int -> Fixity
Fixity Assoc
assoc (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
l)) [LPName]
qns)

fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit :: Located Token -> ParseM (Located String)
fromStrLit Located Token
loc = case Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
loc) of
  StrLit String
str -> Located String -> ParseM (Located String)
forall (m :: * -> *) a. Monad m => a -> m a
return Located Token
loc { thing :: String
thing = String
str }
  TokenT
_          -> Range -> [String] -> ParseM (Located String)
forall a. Range -> [String] -> ParseM a
errorMessage (Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
loc) [String
"Expected a string literal"]


validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType :: Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
rng Type PName
ty =
  case Type PName
ty of
    TLocated Type PName
t Range
r -> Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
r Type PName
t
    TRecord {}   -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Record types"
    TTyApp {}    -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Explicit type application"
    TTuple {}    -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Tuple types"
    TFun {}      -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Function types"
    TSeq {}      -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Sequence types"
    Type PName
TBit         -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Type bit"
    TNum {}      -> ParseM (Type PName)
ok
    TChar {}     -> ParseM (Type PName)
ok
    Type PName
TWild        -> String -> ParseM (Type PName)
forall a. String -> ParseM a
bad String
"Wildcard types"
    TUser {}     -> ParseM (Type PName)
ok

    TParens Type PName
t    -> Range -> Type PName -> ParseM (Type PName)
validDemotedType Range
rng Type PName
t
    TInfix{}     -> ParseM (Type PName)
ok

  where bad :: String -> ParseM a
bad String
x = Range -> [String] -> ParseM a
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng [String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" cannot be demoted."]
        ok :: ParseM (Type PName)
ok    = Type PName -> ParseM (Type PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type PName -> ParseM (Type PName))
-> Type PName -> ParseM (Type PName)
forall a b. (a -> b) -> a -> b
$ Range -> Type PName -> Type PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Range
rng Type PName
ty

-- | Input fields are reversed!
mkRecord :: AddLoc b => Range -> (RecordMap Ident (Range, a) -> b) -> [Named a] -> ParseM b
mkRecord :: Range -> (RecordMap Ident (Range, a) -> b) -> [Named a] -> ParseM b
mkRecord Range
rng RecordMap Ident (Range, a) -> b
f [Named a]
xs =
   case Either (Ident, (Range, a)) (RecordMap Ident (Range, a))
res of
     Left (Ident
nm,(Range
nmRng,a
_)) -> Range -> [String] -> ParseM b
forall a. Range -> [String] -> ParseM a
errorMessage Range
nmRng [String
"Record has repeated field: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Ident -> Doc
forall a. PP a => a -> Doc
pp Ident
nm)]
     Right RecordMap Ident (Range, a)
r -> b -> ParseM b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> ParseM b) -> b -> ParseM b
forall a b. (a -> b) -> a -> b
$ Range -> b -> b
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Range
rng (RecordMap Ident (Range, a) -> b
f RecordMap Ident (Range, a)
r)

  where
  res :: Either (Ident, (Range, a)) (RecordMap Ident (Range, a))
res = [(Ident, (Range, a))]
-> Either (Ident, (Range, a)) (RecordMap Ident (Range, a))
forall a b.
(Show a, Ord a) =>
[(a, b)] -> Either (a, b) (RecordMap a b)
recordFromFieldsErr [(Ident, (Range, a))]
ys
  ys :: [(Ident, (Range, a))]
ys = (Named a -> (Ident, (Range, a)))
-> [Named a] -> [(Ident, (Range, a))]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Named (Located Range
r Ident
nm) a
x) -> (Ident
nm,(Range
r,a
x))) ([Named a] -> [Named a]
forall a. [a] -> [a]
reverse [Named a]
xs)


-- | Input expression are reversed
mkEApp :: NonEmpty (Expr PName) -> ParseM (Expr PName)

mkEApp :: NonEmpty (Expr PName) -> ParseM (Expr PName)
mkEApp es :: NonEmpty (Expr PName)
es@(Expr PName
eLast :| [Expr PName]
_) =
    do Expr PName
f :| [Expr PName]
xs <- Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
eFirst [Expr PName]
rest
       Expr PName -> ParseM (Expr PName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Expr PName, Expr PName) -> Expr PName -> Expr PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
eFirst,Expr PName
eLast) (Expr PName -> Expr PName) -> Expr PName -> Expr PName
forall a b. (a -> b) -> a -> b
$ (Expr PName -> Expr PName -> Expr PName)
-> Expr PName -> [Expr PName] -> Expr PName
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expr PName -> Expr PName -> Expr PName
forall n. Expr n -> Expr n -> Expr n
EApp Expr PName
f [Expr PName]
xs)

  where
  Expr PName
eFirst :| [Expr PName]
rest = NonEmpty (Expr PName) -> NonEmpty (Expr PName)
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty (Expr PName)
es

  {- Type applications are parsed as `ETypeVal (TTyApp fs)` expressions.
     Here we associate them with their corresponding functions,
     converting them into `EAppT` constructs.  For example:

     [ f, x, `{ a = 2 }, y ]
     becomes
     [ f, x ` { a = 2 }, y ]

     The parser associates field and tuple projectors that follow an
     explicit type application onto the TTyApp term, so we also
     have to unwind those projections and reapply them.  For example:

     [ f, x, `{ a = 2 }.f.2, y ]
     becomes
     [ f, (x`{ a = 2 }).f.2, y ]

  -}
  cvtTypeParams :: Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
e [] = NonEmpty (Expr PName) -> ParseM (NonEmpty (Expr PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr PName
e Expr PName -> [Expr PName] -> NonEmpty (Expr PName)
forall a. a -> [a] -> NonEmpty a
:| [])
  cvtTypeParams Expr PName
e (Expr PName
p : [Expr PName]
ps) =
    case Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
p Maybe Range
forall a. Maybe a
Nothing of
      Maybe ([TypeInst PName], [Selector], Maybe Range)
Nothing -> Expr PName -> NonEmpty (Expr PName) -> NonEmpty (Expr PName)
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons Expr PName
e (NonEmpty (Expr PName) -> NonEmpty (Expr PName))
-> ParseM (NonEmpty (Expr PName)) -> ParseM (NonEmpty (Expr PName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
p [Expr PName]
ps

      Just ([TypeInst PName]
fs,[Selector]
ss,Maybe Range
rng) ->
        if Expr PName -> Bool
forall n. Expr n -> Bool
checkAppExpr Expr PName
e then
          let e' :: Expr PName
e'  = (Selector -> Expr PName -> Expr PName)
-> Expr PName -> [Selector] -> Expr PName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Expr PName -> Selector -> Expr PName)
-> Selector -> Expr PName -> Expr PName
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr PName -> Selector -> Expr PName
forall n. Expr n -> Selector -> Expr n
ESel) (Expr PName -> [TypeInst PName] -> Expr PName
forall n. Expr n -> [TypeInst n] -> Expr n
EAppT Expr PName
e [TypeInst PName]
fs) [Selector]
ss
              e'' :: Expr PName
e'' = case Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe (Expr PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
e) Maybe Range
rng of
                      Just Range
r -> Expr PName -> Range -> Expr PName
forall n. Expr n -> Range -> Expr n
ELocated Expr PName
e' Range
r
                      Maybe Range
Nothing -> Expr PName
e'
           in Expr PName -> [Expr PName] -> ParseM (NonEmpty (Expr PName))
cvtTypeParams Expr PName
e'' [Expr PName]
ps
        else
          Range -> [String] -> ParseM (NonEmpty (Expr PName))
forall a. Range -> [String] -> ParseM a
errorMessage (Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe Range
emptyRange (Expr PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
e))
                  [ String
"Explicit type applications can only be applied to named values."
                  , String
"Unexpected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Expr PName -> Doc
forall a. PP a => a -> Doc
pp Expr PName
e)
                  ]

  {- Check if the given expression is a legal target for explicit type application.
     This is basically only variables, but we also allow the parenthesis and
     the phantom "located" AST node.
   -}
  checkAppExpr :: Expr n -> Bool
checkAppExpr Expr n
e =
    case Expr n
e of
      ELocated Expr n
e' Range
_ -> Expr n -> Bool
checkAppExpr Expr n
e'
      EParens Expr n
e'    -> Expr n -> Bool
checkAppExpr Expr n
e'
      EVar{}        -> Bool
True
      Expr n
_             -> Bool
False

  {- Look under a potential chain of selectors to see if we have a TTyApp.
     If so, return the ty app information and the collected selectors
     to reapply.
   -}
  toTypeParam :: Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e Maybe Range
mr =
    case Expr PName
e of
      ELocated Expr PName
e' Range
rng -> Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e' (Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe Maybe Range
mr (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
rng))
      ETypeVal Type PName
t -> Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
forall a.
Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t Maybe Range
mr
      ESel Expr PName
e' Selector
s  -> ( \([TypeInst PName]
fs,[Selector]
ss,Maybe Range
r) -> ([TypeInst PName]
fs,Selector
sSelector -> [Selector] -> [Selector]
forall a. a -> [a] -> [a]
:[Selector]
ss,Maybe Range
r) ) (([TypeInst PName], [Selector], Maybe Range)
 -> ([TypeInst PName], [Selector], Maybe Range))
-> Maybe ([TypeInst PName], [Selector], Maybe Range)
-> Maybe ([TypeInst PName], [Selector], Maybe Range)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr PName
-> Maybe Range -> Maybe ([TypeInst PName], [Selector], Maybe Range)
toTypeParam Expr PName
e' Maybe Range
mr
      Expr PName
_          ->  Maybe ([TypeInst PName], [Selector], Maybe Range)
forall a. Maybe a
Nothing

  toTypeParam' :: Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t Maybe Range
mr =
    case Type PName
t of
      TLocated Type PName
t' Range
rng -> Type PName
-> Maybe Range -> Maybe ([TypeInst PName], [a], Maybe Range)
toTypeParam' Type PName
t' (Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe Maybe Range
mr (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
rng))
      TTyApp [Named (Type PName)]
fs -> ([TypeInst PName], [a], Maybe Range)
-> Maybe ([TypeInst PName], [a], Maybe Range)
forall a. a -> Maybe a
Just ((Named (Type PName) -> TypeInst PName)
-> [Named (Type PName)] -> [TypeInst PName]
forall a b. (a -> b) -> [a] -> [b]
map Named (Type PName) -> TypeInst PName
mkTypeInst [Named (Type PName)]
fs, [], Maybe Range
mr)
      Type PName
_ -> Maybe ([TypeInst PName], [a], Maybe Range)
forall a. Maybe a
Nothing

unOp :: Expr PName -> Expr PName -> Expr PName
unOp :: Expr PName -> Expr PName -> Expr PName
unOp Expr PName
f Expr PName
x = (Expr PName, Expr PName) -> Expr PName -> Expr PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
f,Expr PName
x) (Expr PName -> Expr PName) -> Expr PName -> Expr PName
forall a b. (a -> b) -> a -> b
$ Expr PName -> Expr PName -> Expr PName
forall n. Expr n -> Expr n -> Expr n
EApp Expr PName
f Expr PName
x

-- Use defaultFixity as a placeholder, it will be fixed during renaming.
binOp :: Expr PName -> Located PName -> Expr PName -> Expr PName
binOp :: Expr PName -> LPName -> Expr PName -> Expr PName
binOp Expr PName
x LPName
f Expr PName
y = (Expr PName, Expr PName) -> Expr PName -> Expr PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (Expr PName
x,Expr PName
y) (Expr PName -> Expr PName) -> Expr PName -> Expr PName
forall a b. (a -> b) -> a -> b
$ Expr PName -> LPName -> Fixity -> Expr PName -> Expr PName
forall n. Expr n -> Located n -> Fixity -> Expr n -> Expr n
EInfix Expr PName
x LPName
f Fixity
defaultFixity Expr PName
y

-- An element type ascription is allowed to appear on one of the arguments.
eFromTo :: Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> ParseM (Expr PName)
eFromTo :: Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> ParseM (Expr PName)
eFromTo Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 =
  case (Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped (Expr PName -> Maybe (Expr PName, Type PName))
-> Maybe (Expr PName) -> Maybe (Expr PName, Type PName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Expr PName)
e2, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
    (Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1' Maybe (Expr PName)
e2 Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
    (Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 (Expr PName -> Maybe (Expr PName)
forall a. a -> Maybe a
Just Expr PName
e2') Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3' (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 Maybe (Type PName)
forall a. Maybe a
Nothing
    (Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
 Maybe (Expr PName, Type PName))
_ -> Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"A sequence enumeration may have at most one element type annotation."]

eFromToBy :: Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName)
eFromToBy :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Bool
-> ParseM (Expr PName)
eFromToBy Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Bool
isStrictBound =
  case (Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
    (Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1' Expr PName
e2 Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2' Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3' (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing)       -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
forall a. Maybe a
Nothing Bool
isStrictBound
    (Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
 Maybe (Expr PName, Type PName))
_ -> Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"A sequence enumeration may have at most one element type annotation."]

eFromToByTyped :: Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName)
eFromToByTyped :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
t Bool
isStrictBound =
  Bool
-> Type PName
-> Type PName
-> Type PName
-> Maybe (Type PName)
-> Expr PName
forall n.
Bool -> Type n -> Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToBy Bool
isStrictBound
      (Type PName
 -> Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM
     (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
      ParseM
  (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e2
      ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e3
      ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t

eFromToDownBy ::
  Range -> Expr PName -> Expr PName -> Expr PName -> Bool -> ParseM (Expr PName)
eFromToDownBy :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Bool
-> ParseM (Expr PName)
eFromToDownBy Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Bool
isStrictBound =
  case (Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2, Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e3) of
    (Just (Expr PName
e1', Type PName
t), Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1' Expr PName
e2 Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e2', Type PName
t), Maybe (Expr PName, Type PName)
Nothing) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2' Expr PName
e3 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Just (Expr PName
e3', Type PName
t)) -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3' (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t) Bool
isStrictBound
    (Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing, Maybe (Expr PName, Type PName)
Nothing)       -> Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
forall a. Maybe a
Nothing Bool
isStrictBound
    (Maybe (Expr PName, Type PName), Maybe (Expr PName, Type PName),
 Maybe (Expr PName, Type PName))
_ -> Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"A sequence enumeration may have at most one element type annotation."]

eFromToDownByTyped ::
  Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName)
eFromToDownByTyped :: Range
-> Expr PName
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> Bool
-> ParseM (Expr PName)
eFromToDownByTyped Range
r Expr PName
e1 Expr PName
e2 Expr PName
e3 Maybe (Type PName)
t Bool
isStrictBound =
  Bool
-> Type PName
-> Type PName
-> Type PName
-> Maybe (Type PName)
-> Expr PName
forall n.
Bool -> Type n -> Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToDownBy Bool
isStrictBound
      (Type PName
 -> Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM
     (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
      ParseM
  (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e2
      ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e3
      ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t


asETyped :: Expr n -> Maybe (Expr n, Type n)
asETyped :: Expr n -> Maybe (Expr n, Type n)
asETyped (ELocated Expr n
e Range
_) = Expr n -> Maybe (Expr n, Type n)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr n
e
asETyped (ETyped Expr n
e Type n
t) = (Expr n, Type n) -> Maybe (Expr n, Type n)
forall a. a -> Maybe a
Just (Expr n
e, Type n
t)
asETyped Expr n
_ = Maybe (Expr n, Type n)
forall a. Maybe a
Nothing

eFromToType ::
  Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToType :: Range
-> Expr PName
-> Maybe (Expr PName)
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToType Range
r Expr PName
e1 Maybe (Expr PName)
e2 Expr PName
e3 Maybe (Type PName)
t =
  Type PName
-> Maybe (Type PName)
-> Type PName
-> Maybe (Type PName)
-> Expr PName
forall n.
Type n -> Maybe (Type n) -> Type n -> Maybe (Type n) -> Expr n
EFromTo (Type PName
 -> Maybe (Type PName)
 -> Type PName
 -> Maybe (Type PName)
 -> Expr PName)
-> ParseM (Type PName)
-> ParseM
     (Maybe (Type PName)
      -> Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
          ParseM
  (Maybe (Type PName)
   -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName))
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr PName -> ParseM (Type PName))
-> Maybe (Expr PName) -> ParseM (Maybe (Type PName))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r) Maybe (Expr PName)
e2
          ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e3
          ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t

eFromToLessThan ::
  Range -> Expr PName -> Expr PName -> ParseM (Expr PName)
eFromToLessThan :: Range -> Expr PName -> Expr PName -> ParseM (Expr PName)
eFromToLessThan Range
r Expr PName
e1 Expr PName
e2 =
  case Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e2 of
    Just (Expr PName, Type PName)
_  -> Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"The exclusive upper bound of an enumeration may not have a type annotation."]
    Maybe (Expr PName, Type PName)
Nothing ->
      case Expr PName -> Maybe (Expr PName, Type PName)
forall n. Expr n -> Maybe (Expr n, Type n)
asETyped Expr PName
e1 of
        Maybe (Expr PName, Type PName)
Nothing      -> Range
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToLessThanType Range
r Expr PName
e1  Expr PName
e2 Maybe (Type PName)
forall a. Maybe a
Nothing
        Just (Expr PName
e1',Type PName
t) -> Range
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToLessThanType Range
r Expr PName
e1' Expr PName
e2 (Type PName -> Maybe (Type PName)
forall a. a -> Maybe a
Just Type PName
t)

eFromToLessThanType ::
  Range -> Expr PName -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToLessThanType :: Range
-> Expr PName
-> Expr PName
-> Maybe (Type PName)
-> ParseM (Expr PName)
eFromToLessThanType Range
r Expr PName
e1 Expr PName
e2 Maybe (Type PName)
t =
  Type PName -> Type PName -> Maybe (Type PName) -> Expr PName
forall n. Type n -> Type n -> Maybe (Type n) -> Expr n
EFromToLessThan
    (Type PName -> Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName)
-> ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e1
    ParseM (Type PName -> Maybe (Type PName) -> Expr PName)
-> ParseM (Type PName) -> ParseM (Maybe (Type PName) -> Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
e2
    ParseM (Maybe (Type PName) -> Expr PName)
-> ParseM (Maybe (Type PName)) -> ParseM (Expr PName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Type PName) -> ParseM (Maybe (Type PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Type PName)
t

exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT Range
r Expr PName
expr =
  case Expr PName -> Maybe (Type PName)
translateExprToNumT Expr PName
expr of
    Just Type PName
t -> Type PName -> ParseM (Type PName)
forall (m :: * -> *) a. Monad m => a -> m a
return Type PName
t
    Maybe (Type PName)
Nothing -> ParseM (Type PName)
forall a. ParseM a
bad
  where
  bad :: ParseM a
bad = Range -> [String] -> ParseM a
forall a. Range -> [String] -> ParseM a
errorMessage (Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe Range
r (Expr PName -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc Expr PName
expr))
        [ String
"The boundaries of .. sequences should be valid numeric types."
        , String
"The expression `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Expr PName -> Doc
forall a. PP a => a -> Doc
pp Expr PName
expr) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` is not."
        ]


-- | WARNING: This is a bit of a hack.
-- It is used to represent anonymous type applications.
anonTyApp :: Maybe Range -> [Type PName] -> Type PName
anonTyApp :: Maybe Range -> [Type PName] -> Type PName
anonTyApp ~(Just Range
r) [Type PName]
ts = Type PName -> Range -> Type PName
forall n. Type n -> Range -> Type n
TLocated ([Named (Type PName)] -> Type PName
forall n. [Named (Type n)] -> Type n
TTyApp ((Type PName -> Named (Type PName))
-> [Type PName] -> [Named (Type PName)]
forall a b. (a -> b) -> [a] -> [b]
map Type PName -> Named (Type PName)
forall a. a -> Named a
toField [Type PName]
ts)) Range
r
  where noName :: Located Ident
noName    = Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: Ident
thing = Text -> Ident
mkIdent (String -> Text
T.pack String
"") }
        toField :: a -> Named a
toField a
t = Named :: forall a. Located Ident -> a -> Named a
Named { name :: Located Ident
name = Located Ident
noName, value :: a
value = a
t }

exportDecl :: Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl :: Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located Text)
mbDoc ExportType
e Decl PName
d = TopLevel (Decl PName) -> TopDecl PName
forall name. TopLevel (Decl name) -> TopDecl name
Decl TopLevel :: forall a. ExportType -> Maybe (Located Text) -> a -> TopLevel a
TopLevel { tlExport :: ExportType
tlExport = ExportType
e
                                     , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
mbDoc
                                     , tlValue :: Decl PName
tlValue  = Decl PName
d }

exportNewtype :: ExportType -> Maybe (Located Text) -> Newtype PName ->
                                                            TopDecl PName
exportNewtype :: ExportType
-> Maybe (Located Text) -> Newtype PName -> TopDecl PName
exportNewtype ExportType
e Maybe (Located Text)
d Newtype PName
n = TopLevel (Newtype PName) -> TopDecl PName
forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype TopLevel :: forall a. ExportType -> Maybe (Located Text) -> a -> TopLevel a
TopLevel { tlExport :: ExportType
tlExport = ExportType
e
                                         , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
d
                                         , tlValue :: Newtype PName
tlValue  = Newtype PName
n }

exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName
exportModule :: Maybe (Located Text) -> NestedModule PName -> TopDecl PName
exportModule Maybe (Located Text)
mbDoc NestedModule PName
m = TopLevel (NestedModule PName) -> TopDecl PName
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule TopLevel :: forall a. ExportType -> Maybe (Located Text) -> a -> TopLevel a
TopLevel { tlExport :: ExportType
tlExport = ExportType
Public
                                        , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
mbDoc
                                        , tlValue :: NestedModule PName
tlValue  = NestedModule PName
m }

mkParFun :: Maybe (Located Text) ->
            Located PName ->
            Schema PName ->
            TopDecl PName
mkParFun :: Maybe (Located Text) -> LPName -> Schema PName -> TopDecl PName
mkParFun Maybe (Located Text)
mbDoc LPName
n Schema PName
s = ParameterFun PName -> TopDecl PName
forall name. ParameterFun name -> TopDecl name
DParameterFun ParameterFun :: forall name.
Located name
-> Schema name -> Maybe Text -> Maybe Fixity -> ParameterFun name
ParameterFun { pfName :: LPName
pfName = LPName
n
                                                , pfSchema :: Schema PName
pfSchema = Schema PName
s
                                                , pfDoc :: Maybe Text
pfDoc = Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc
                                                , pfFixity :: Maybe Fixity
pfFixity = Maybe Fixity
forall a. Maybe a
Nothing
                                                }

mkParType :: Maybe (Located Text) ->
             Located PName ->
             Located Kind ->
             ParseM (TopDecl PName)
mkParType :: Maybe (Located Text)
-> LPName -> Located Kind -> ParseM (TopDecl PName)
mkParType Maybe (Located Text)
mbDoc LPName
n Located Kind
k =
  do Int
num <- (Config -> Position -> S -> Either ParseError (Int, S))
-> ParseM Int
forall a.
(Config -> Position -> S -> Either ParseError (a, S)) -> ParseM a
P ((Config -> Position -> S -> Either ParseError (Int, S))
 -> ParseM Int)
-> (Config -> Position -> S -> Either ParseError (Int, S))
-> ParseM Int
forall a b. (a -> b) -> a -> b
$ \Config
_ Position
_ S
s -> let nu :: Int
nu = S -> Int
sNextTyParamNum S
s
                          in (Int, S) -> Either ParseError (Int, S)
forall a b. b -> Either a b
Right (Int
nu, S
s { sNextTyParamNum :: Int
sNextTyParamNum = Int
nu Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 })
     TopDecl PName -> ParseM (TopDecl PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParameterType PName -> TopDecl PName
forall name. ParameterType name -> TopDecl name
DParameterType
             ParameterType :: forall name.
Located name
-> Kind -> Maybe Text -> Maybe Fixity -> Int -> ParameterType name
ParameterType { ptName :: LPName
ptName    = LPName
n
                           , ptKind :: Kind
ptKind    = Located Kind -> Kind
forall a. Located a -> a
thing Located Kind
k
                           , ptDoc :: Maybe Text
ptDoc     = Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Located Text)
mbDoc
                           , ptFixity :: Maybe Fixity
ptFixity  = Maybe Fixity
forall a. Maybe a
Nothing
                           , ptNumber :: Int
ptNumber  = Int
num
                           })

changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport ExportType
e = (TopDecl PName -> TopDecl PName)
-> [TopDecl PName] -> [TopDecl PName]
forall a b. (a -> b) -> [a] -> [b]
map TopDecl PName -> TopDecl PName
forall name. TopDecl name -> TopDecl name
change
  where
  change :: TopDecl name -> TopDecl name
change (Decl TopLevel (Decl name)
d)      = TopLevel (Decl name) -> TopDecl name
forall name. TopLevel (Decl name) -> TopDecl name
Decl      TopLevel (Decl name)
d { tlExport :: ExportType
tlExport = ExportType
e }
  change (DPrimType TopLevel (PrimType name)
t) = TopLevel (PrimType name) -> TopDecl name
forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel (PrimType name)
t { tlExport :: ExportType
tlExport = ExportType
e }
  change (TDNewtype TopLevel (Newtype name)
n) = TopLevel (Newtype name) -> TopDecl name
forall name. TopLevel (Newtype name) -> TopDecl name
TDNewtype TopLevel (Newtype name)
n { tlExport :: ExportType
tlExport = ExportType
e }
  change (DModule TopLevel (NestedModule name)
m)   = TopLevel (NestedModule name) -> TopDecl name
forall name. TopLevel (NestedModule name) -> TopDecl name
DModule   TopLevel (NestedModule name)
m { tlExport :: ExportType
tlExport = ExportType
e }
  change td :: TopDecl name
td@Include{}  = TopDecl name
td
  change td :: TopDecl name
td@DImport{}  = TopDecl name
td
  change (DParameterType {}) = String -> [String] -> TopDecl name
forall a. HasCallStack => String -> [String] -> a
panic String
"changeExport" [String
"private type parameter?"]
  change (DParameterFun {})  = String -> [String] -> TopDecl name
forall a. HasCallStack => String -> [String] -> a
panic String
"changeExport" [String
"private value parameter?"]
  change (DParameterConstraint {}) =
    String -> [String] -> TopDecl name
forall a. HasCallStack => String -> [String] -> a
panic String
"changeExport" [String
"private type constraint parameter?"]

mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst Named (Type PName)
x | Ident -> Bool
nullIdent (Located Ident -> Ident
forall a. Located a -> a
thing (Named (Type PName) -> Located Ident
forall a. Named a -> Located Ident
name Named (Type PName)
x)) = Type PName -> TypeInst PName
forall name. Type name -> TypeInst name
PosInst (Named (Type PName) -> Type PName
forall a. Named a -> a
value Named (Type PName)
x)
             | Bool
otherwise                  = Named (Type PName) -> TypeInst PName
forall name. Named (Type name) -> TypeInst name
NamedInst Named (Type PName)
x


mkTParam :: Located Ident -> Maybe Kind -> ParseM (TParam PName)
mkTParam :: Located Ident -> Maybe Kind -> ParseM (TParam PName)
mkTParam Located { srcRange :: forall a. Located a -> Range
srcRange = Range
rng, thing :: forall a. Located a -> a
thing = Ident
n } Maybe Kind
k
  | Ident
n Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
widthIdent = Range -> [String] -> ParseM (TParam PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng [String
"`width` is not a valid type parameter name."]
  | Bool
otherwise       = TParam PName -> ParseM (TParam PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Maybe Kind -> Maybe Range -> TParam PName
forall n. n -> Maybe Kind -> Maybe Range -> TParam n
TParam (Ident -> PName
mkUnqual Ident
n) Maybe Kind
k (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
rng))

mkTySyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkTySyn :: LPName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkTySyn LPName
ln [TParam PName]
ps Type PName
b
  | PName -> Ident
getIdent (LPName -> PName
forall a. Located a -> a
thing LPName
ln) Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
widthIdent =
    Range -> [String] -> ParseM (Decl PName)
forall a. Range -> [String] -> ParseM a
errorMessage (LPName -> Range
forall a. Located a -> Range
srcRange LPName
ln) [String
"`width` is not a valid type synonym name."]

  | Bool
otherwise =
    Decl PName -> ParseM (Decl PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PName -> ParseM (Decl PName))
-> Decl PName -> ParseM (Decl PName)
forall a b. (a -> b) -> a -> b
$ TySyn PName -> Decl PName
forall name. TySyn name -> Decl name
DType (TySyn PName -> Decl PName) -> TySyn PName -> Decl PName
forall a b. (a -> b) -> a -> b
$ LPName
-> Maybe Fixity -> [TParam PName] -> Type PName -> TySyn PName
forall n.
Located n -> Maybe Fixity -> [TParam n] -> Type n -> TySyn n
TySyn LPName
ln Maybe Fixity
forall a. Maybe a
Nothing [TParam PName]
ps Type PName
b

mkPropSyn :: Located PName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkPropSyn :: LPName -> [TParam PName] -> Type PName -> ParseM (Decl PName)
mkPropSyn LPName
ln [TParam PName]
ps Type PName
b
  | PName -> Ident
getIdent (LPName -> PName
forall a. Located a -> a
thing LPName
ln) Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
widthIdent =
    Range -> [String] -> ParseM (Decl PName)
forall a. Range -> [String] -> ParseM a
errorMessage (LPName -> Range
forall a. Located a -> Range
srcRange LPName
ln) [String
"`width` is not a valid constraint synonym name."]

  | Bool
otherwise =
    PropSyn PName -> Decl PName
forall name. PropSyn name -> Decl name
DProp (PropSyn PName -> Decl PName)
-> (Located [Prop PName] -> PropSyn PName)
-> Located [Prop PName]
-> Decl PName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPName
-> Maybe Fixity -> [TParam PName] -> [Prop PName] -> PropSyn PName
forall n.
Located n -> Maybe Fixity -> [TParam n] -> [Prop n] -> PropSyn n
PropSyn LPName
ln Maybe Fixity
forall a. Maybe a
Nothing [TParam PName]
ps ([Prop PName] -> PropSyn PName)
-> (Located [Prop PName] -> [Prop PName])
-> Located [Prop PName]
-> PropSyn PName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located [Prop PName] -> [Prop PName]
forall a. Located a -> a
thing (Located [Prop PName] -> Decl PName)
-> ParseM (Located [Prop PName]) -> ParseM (Decl PName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
b

polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm Range
rng Integer
k Integer
p
  | Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0          = (Bool, Integer) -> ParseM (Bool, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Integer
p)
  | Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1          = (Bool, Integer) -> ParseM (Bool, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Integer
p)
  | Bool
otherwise       = Range -> [String] -> ParseM (Bool, Integer)
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng [String
"Invalid polynomial coefficient"]

mkPoly :: Range -> [ (Bool,Integer) ] -> ParseM (Expr PName)
mkPoly :: Range -> [(Bool, Integer)] -> ParseM (Expr PName)
mkPoly Range
rng [(Bool, Integer)]
terms
  | Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int) = Integer -> [Int] -> ParseM (Expr PName)
mk Integer
0 ((Integer -> Int) -> [Integer] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Int
forall a. Num a => Integer -> a
fromInteger [Integer]
bits)
  | Bool
otherwise = Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng [String
"Polynomial literal too large: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
w]

  where
  w :: Integer
w    = case [(Bool, Integer)]
terms of
           [] -> Integer
0
           [(Bool, Integer)]
_  -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (((Bool, Integer) -> Integer) -> [(Bool, Integer)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Integer) -> Integer
forall a b. (a, b) -> b
snd [(Bool, Integer)]
terms)

  bits :: [Integer]
bits = [ Integer
n | (Bool
True,Integer
n) <- [(Bool, Integer)]
terms ]

  mk :: Integer -> [Int] -> ParseM (Expr PName)
  mk :: Integer -> [Int] -> ParseM (Expr PName)
mk Integer
res [] = Expr PName -> ParseM (Expr PName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr PName -> ParseM (Expr PName))
-> Expr PName -> ParseM (Expr PName)
forall a b. (a -> b) -> a -> b
$ Literal -> Expr PName
forall n. Literal -> Expr n
ELit (Literal -> Expr PName) -> Literal -> Expr PName
forall a b. (a -> b) -> a -> b
$ Integer -> NumInfo -> Literal
ECNum Integer
res (Int -> NumInfo
PolyLit (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
w :: Int))

  mk Integer
res (Int
n : [Int]
ns)
    | Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
res Int
n = Range -> [String] -> ParseM (Expr PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
rng
                       [String
"Polynomial contains multiple terms with exponent " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n]
    | Bool
otherwise     = Integer -> [Int] -> ParseM (Expr PName)
mk (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
setBit Integer
res Int
n) [Int]
ns


-- NOTE: The list of patterns is reversed!
mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty LPName
f [Pattern PName]
ps Expr PName
e = (LPName, Expr PName) -> Decl PName -> Decl PName
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at (LPName
f,Expr PName
e) (Decl PName -> Decl PName) -> Decl PName -> 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
-> ExportType
-> Bind name
Bind { bName :: LPName
bName       = LPName
f
                               , bParams :: [Pattern PName]
bParams     = [Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps
                               , 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    = [Pragma
PragmaProperty]
                               , 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
                               , bExport :: ExportType
bExport     = ExportType
Public
                               }

-- NOTE: The lists of patterns are reversed!
mkIndexedDecl ::
  LPName -> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl :: LPName
-> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl LPName
f ([Pattern PName]
ps, [Pattern PName]
ixs) Expr PName
e =
  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
-> ExportType
-> Bind name
Bind { bName :: LPName
bName       = LPName
f
             , bParams :: [Pattern PName]
bParams     = [Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps
             , 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
rhs))
             , 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
             , bExport :: ExportType
bExport     = ExportType
Public
             }
  where
    rhs :: Expr PName
    rhs :: Expr PName
rhs = [Pattern PName] -> Expr PName -> Expr PName
mkGenerate ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
e

-- NOTE: The lists of patterns are reversed!
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr ([Pattern PName]
ps, [Pattern PName]
ixs) Expr PName
body
  | [Pattern PName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern PName]
ps = [Pattern PName] -> Expr PName -> Expr PName
mkGenerate ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
body
  | Bool
otherwise = FunDesc PName -> [Pattern PName] -> Expr PName -> Expr PName
forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun FunDesc PName
forall n. FunDesc n
emptyFunDesc ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ps) ([Pattern PName] -> Expr PName -> Expr PName
mkGenerate ([Pattern PName] -> [Pattern PName]
forall a. [a] -> [a]
reverse [Pattern PName]
ixs) Expr PName
body)

mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate [Pattern PName]
pats Expr PName
body =
  (Pattern PName -> Expr PName -> Expr PName)
-> Expr PName -> [Pattern PName] -> Expr PName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Pattern PName
pat Expr PName
e -> Expr PName -> Expr PName
forall n. Expr n -> Expr n
EGenerate (FunDesc PName -> [Pattern PName] -> Expr PName -> Expr PName
forall n. FunDesc n -> [Pattern n] -> Expr n -> Expr n
EFun FunDesc PName
forall n. FunDesc n
emptyFunDesc [Pattern PName
pat] Expr PName
e)) Expr PName
body [Pattern PName]
pats

mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf [(Expr PName, Expr PName)]
ifThens Expr PName
theElse = ((Expr PName, Expr PName) -> Expr PName -> Expr PName)
-> Expr PName -> [(Expr PName, Expr PName)] -> Expr PName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expr PName, Expr PName) -> Expr PName -> Expr PName
forall n. (Expr n, Expr n) -> Expr n -> Expr n
addIfThen Expr PName
theElse [(Expr PName, Expr PName)]
ifThens
    where
    addIfThen :: (Expr n, Expr n) -> Expr n -> Expr n
addIfThen (Expr n
cond, Expr n
doexpr) Expr n
elseExpr = Expr n -> Expr n -> Expr n -> Expr n
forall n. Expr n -> Expr n -> Expr n -> Expr n
EIf Expr n
cond Expr n
doexpr Expr n
elseExpr

-- | Generate a signature and a primitive binding.  The reason for generating
-- both instead of just adding the signature at this point is that it means the
-- primitive declarations don't need to be treated differently in the noPat
-- pass.  This is also the reason we add the doc to the TopLevel constructor,
-- instead of just place it on the binding directly.  A better solution might be
-- to just have a different constructor for primitives.
mkPrimDecl ::
  Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl :: Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl Maybe (Located Text)
mbDoc LPName
ln Schema PName
sig =
  [ Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located Text)
mbDoc ExportType
Public
    (Decl PName -> TopDecl PName) -> Decl PName -> TopDecl 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
-> ExportType
-> Bind name
Bind { bName :: LPName
bName      = LPName
ln
                 , bParams :: [Pattern PName]
bParams    = []
                 , bDef :: Located (BindDef PName)
bDef       = Schema PName -> Located (BindDef PName) -> Located (BindDef PName)
forall l t. (HasLoc l, AddLoc t) => l -> t -> t
at Schema PName
sig (Range -> BindDef PName -> Located (BindDef PName)
forall a. Range -> a -> Located a
Located Range
emptyRange BindDef PName
forall name. BindDef name
DPrim)
                 , bSignature :: Maybe (Schema PName)
bSignature = Maybe (Schema PName)
forall a. Maybe a
Nothing
                 , bPragmas :: [Pragma]
bPragmas   = []
                 , bMono :: Bool
bMono      = Bool
False
                 , bInfix :: Bool
bInfix     = Ident -> Bool
isInfixIdent (PName -> Ident
getIdent (LPName -> PName
forall a. Located a -> a
thing LPName
ln))
                 , bFixity :: Maybe Fixity
bFixity    = Maybe Fixity
forall a. Maybe a
Nothing
                 , bDoc :: Maybe Text
bDoc       = Maybe Text
forall a. Maybe a
Nothing
                 , bExport :: ExportType
bExport    = ExportType
Public
                 }
  , Maybe (Located Text) -> ExportType -> Decl PName -> TopDecl PName
exportDecl Maybe (Located Text)
forall a. Maybe a
Nothing ExportType
Public
    (Decl PName -> TopDecl PName) -> Decl PName -> TopDecl PName
forall a b. (a -> b) -> a -> b
$ [LPName] -> Schema PName -> Decl PName
forall name. [Located name] -> Schema name -> Decl name
DSignature [LPName
ln] Schema PName
sig
  ]

mkPrimTypeDecl ::
  Maybe (Located Text) ->
  Schema PName ->
  Located Kind ->
  ParseM [TopDecl PName]
mkPrimTypeDecl :: Maybe (Located Text)
-> Schema PName -> Located Kind -> ParseM [TopDecl PName]
mkPrimTypeDecl Maybe (Located Text)
mbDoc (Forall [TParam PName]
as [Prop PName]
qs Type PName
st ~(Just Range
schema_rng)) Located Kind
finK =
  case Range -> Type PName -> Maybe (LPName, [LPName])
forall a. Eq a => Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
schema_rng Type PName
st of
    Just (LPName
n,[LPName]
xs) ->
      do [(PName, (TParam PName, Kind))]
vs <- (TParam PName -> ParseM (PName, (TParam PName, Kind)))
-> [TParam PName] -> ParseM [(PName, (TParam PName, Kind))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TParam PName -> ParseM (PName, (TParam PName, Kind))
forall n. TParam n -> ParseM (n, (TParam n, Kind))
tpK [TParam PName]
as
         Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PName] -> Bool
forall a. Eq a => [a] -> Bool
distinct (((PName, (TParam PName, Kind)) -> PName)
-> [(PName, (TParam PName, Kind))] -> [PName]
forall a b. (a -> b) -> [a] -> [b]
map (PName, (TParam PName, Kind)) -> PName
forall a b. (a, b) -> a
fst [(PName, (TParam PName, Kind))]
vs)) (ParseM () -> ParseM ()) -> ParseM () -> ParseM ()
forall a b. (a -> b) -> a -> b
$
            Range -> [String] -> ParseM ()
forall a. Range -> [String] -> ParseM a
errorMessage Range
schema_rng [String
"Repeated parameters."]
         let kindMap :: Map PName (TParam PName, Kind)
kindMap = [(PName, (TParam PName, Kind))] -> Map PName (TParam PName, Kind)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PName, (TParam PName, Kind))]
vs
             lkp :: LPName -> ParseM (TParam PName, Kind)
lkp LPName
v = case PName
-> Map PName (TParam PName, Kind) -> Maybe (TParam PName, Kind)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (LPName -> PName
forall a. Located a -> a
thing LPName
v) Map PName (TParam PName, Kind)
kindMap of
                       Just (TParam PName
k,Kind
tp)  -> (TParam PName, Kind) -> ParseM (TParam PName, Kind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TParam PName
k,Kind
tp)
                       Maybe (TParam PName, Kind)
Nothing ->
                        Range -> [String] -> ParseM (TParam PName, Kind)
forall a. Range -> [String] -> ParseM a
errorMessage
                            (LPName -> Range
forall a. Located a -> Range
srcRange LPName
v)
                            [String
"Undefined parameter: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (PName -> Doc
forall a. PP a => a -> Doc
pp (LPName -> PName
forall a. Located a -> a
thing LPName
v))]
         ([TParam PName]
as',[Kind]
ins) <- [(TParam PName, Kind)] -> ([TParam PName], [Kind])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TParam PName, Kind)] -> ([TParam PName], [Kind]))
-> ParseM [(TParam PName, Kind)] -> ParseM ([TParam PName], [Kind])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LPName -> ParseM (TParam PName, Kind))
-> [LPName] -> ParseM [(TParam PName, Kind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPName -> ParseM (TParam PName, Kind)
lkp [LPName]
xs
         Bool -> ParseM () -> ParseM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(PName, (TParam PName, Kind))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PName, (TParam PName, Kind))]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [LPName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LPName]
xs) (ParseM () -> ParseM ()) -> ParseM () -> ParseM ()
forall a b. (a -> b) -> a -> b
$
           Range -> [String] -> ParseM ()
forall a. Range -> [String] -> ParseM a
errorMessage Range
schema_rng [String
"All parameters should appear in the type."]

         let ki :: Located Kind
ki = Located Kind
finK { thing :: Kind
thing = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Kind -> Kind -> Kind
KFun (Located Kind -> Kind
forall a. Located a -> a
thing Located Kind
finK) [Kind]
ins }

         [TopDecl PName] -> ParseM [TopDecl PName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ TopLevel (PrimType PName) -> TopDecl PName
forall name. TopLevel (PrimType name) -> TopDecl name
DPrimType TopLevel :: forall a. ExportType -> Maybe (Located Text) -> a -> TopLevel a
TopLevel
                  { tlExport :: ExportType
tlExport = ExportType
Public
                  , tlDoc :: Maybe (Located Text)
tlDoc    = Maybe (Located Text)
mbDoc
                  , tlValue :: PrimType PName
tlValue  = PrimType :: forall name.
Located name
-> Located Kind
-> ([TParam name], [Prop name])
-> Maybe Fixity
-> PrimType name
PrimType { primTName :: LPName
primTName   = LPName
n
                                        , primTKind :: Located Kind
primTKind   = Located Kind
ki
                                        , primTCts :: ([TParam PName], [Prop PName])
primTCts    = ([TParam PName]
as',[Prop PName]
qs)
                                        , primTFixity :: Maybe Fixity
primTFixity = Maybe Fixity
forall a. Maybe a
Nothing
                                        }
                 }
              ]

    Maybe (LPName, [LPName])
Nothing -> Range -> [String] -> ParseM [TopDecl PName]
forall a. Range -> [String] -> ParseM a
errorMessage Range
schema_rng [String
"Invalid primitive signature"]

  where
  splitT :: Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
r Type a
ty = case Type a
ty of
                  TLocated Type a
t Range
r1 -> Range -> Type a -> Maybe (Located a, [Located a])
splitT Range
r1 Type a
t
                  TUser a
n [Type a]
ts -> Range -> Located a -> [Type a] -> Maybe (Located a, [Located a])
forall a a.
Eq a =>
Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
n } [Type a]
ts
                  TInfix Type a
t1 Located a
n Fixity
_ Type a
t2  -> Range -> Located a -> [Type a] -> Maybe (Located a, [Located a])
forall a a.
Eq a =>
Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r Located a
n [Type a
t1,Type a
t2]
                  Type a
_ -> Maybe (Located a, [Located a])
forall a. Maybe a
Nothing

  mkT :: Range -> a -> [Type a] -> Maybe (a, [Located a])
mkT Range
r a
n [Type a]
ts = do [Located a]
ts1 <- (Type a -> Maybe (Located a)) -> [Type a] -> Maybe [Located a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> Type a -> Maybe (Located a)
forall a. Range -> Type a -> Maybe (Located a)
isVar Range
r) [Type a]
ts
                  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([a] -> Bool
forall a. Eq a => [a] -> Bool
distinct ((Located a -> a) -> [Located a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Located a -> a
forall a. Located a -> a
thing [Located a]
ts1))
                  (a, [Located a]) -> Maybe (a, [Located a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
n,[Located a]
ts1)

  isVar :: Range -> Type a -> Maybe (Located a)
isVar Range
r Type a
ty = case Type a
ty of
                 TLocated Type a
t Range
r1  -> Range -> Type a -> Maybe (Located a)
isVar Range
r1 Type a
t
                 TUser a
n []     -> Located a -> Maybe (Located a)
forall a. a -> Maybe a
Just Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
n }
                 Type a
_              -> Maybe (Located a)
forall a. Maybe a
Nothing

  -- inefficient, but the lists should be small
  distinct :: [a] -> Bool
distinct [a]
xs = case [a]
xs of
                  [] -> Bool
True
                  a
x : [a]
ys -> Bool -> Bool
not (a
x a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
ys) Bool -> Bool -> Bool
&& [a] -> Bool
distinct [a]
ys

  tpK :: TParam n -> ParseM (n, (TParam n, Kind))
tpK TParam n
tp = case TParam n -> Maybe Kind
forall n. TParam n -> Maybe Kind
tpKind TParam n
tp of
             Just Kind
k  -> (n, (TParam n, Kind)) -> ParseM (n, (TParam n, Kind))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TParam n -> n
forall n. TParam n -> n
tpName TParam n
tp, (TParam n
tp,Kind
k))
             Maybe Kind
Nothing ->
              case TParam n -> Maybe Range
forall n. TParam n -> Maybe Range
tpRange TParam n
tp of
                Just Range
r -> Range -> [String] -> ParseM (n, (TParam n, Kind))
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"Parameters need a kind annotation"]
                Maybe Range
Nothing -> String -> [String] -> ParseM (n, (TParam n, Kind))
forall a. HasCallStack => String -> [String] -> a
panic String
"mkPrimTypeDecl"
                              [ String
"Missing range on schema parameter." ]


-- | Fix-up the documentation strings by removing the comment delimiters on each
-- end, and stripping out common prefixes on all the remaining lines.
mkDoc :: Located Text -> Located Text
mkDoc :: Located Text -> Located Text
mkDoc Located Text
ltxt = Located Text
ltxt { thing :: Text
thing = Text
docStr }
  where

  docStr :: Text
docStr = [Text] -> Text
T.unlines
         ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
dropPrefix
         ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
trimFront
         ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines
         (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
commentChar
         (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Located Text -> Text
forall a. Located a -> a
thing Located Text
ltxt

  commentChar :: Char -> Bool
  commentChar :: Char -> Bool
commentChar Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"/* \r\n\t" :: String)

  prefixDroppable :: Char -> Bool
prefixDroppable Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"* \r\n\t" :: String)

  whitespaceChar :: Char -> Bool
  whitespaceChar :: Char -> Bool
whitespaceChar Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
" \r\n\t" :: String)

  trimFront :: [Text] -> [Text]
trimFront []                     = []
  trimFront (Text
l:[Text]
ls)
    | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
commentChar Text
l = [Text]
ls
    | Bool
otherwise           = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
commentChar Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ls

  dropPrefix :: [Text] -> [Text]
dropPrefix []        = []
  dropPrefix [Text
t]       = [(Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
commentChar Text
t]
  dropPrefix ts :: [Text]
ts@(Text
l:[Text]
ls) =
    case Text -> Maybe (Char, Text)
T.uncons Text
l of
      Just (Char
c,Text
_) | Char -> Bool
prefixDroppable Char
c Bool -> Bool -> Bool
&&
                   (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Text -> Bool
commonPrefix Char
c) [Text]
ls -> [Text] -> [Text]
dropPrefix ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
T.drop Int
1) [Text]
ts)
      Maybe (Char, Text)
_                                    -> [Text]
ts

    where
    commonPrefix :: Char -> Text -> Bool
commonPrefix Char
c Text
t =
      case Text -> Maybe (Char, Text)
T.uncons Text
t of
        Just (Char
c',Text
_) -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c'
        Maybe (Char, Text)
Nothing     -> Char -> Bool
whitespaceChar Char
c -- end-of-line matches any whitespace


distrLoc :: Located [a] -> [Located a]
distrLoc :: Located [a] -> [Located a]
distrLoc Located [a]
x = [ Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
r, thing :: a
thing = a
a } | a
a <- Located [a] -> [a]
forall a. Located a -> a
thing Located [a]
x ]
  where r :: Range
r = Located [a] -> Range
forall a. Located a -> Range
srcRange Located [a]
x


mkProp :: Type PName -> ParseM (Located [Prop PName])
mkProp :: Type PName -> ParseM (Located [Prop PName])
mkProp Type PName
ty =
  case Type PName
ty of
    TLocated Type PName
t Range
r -> Range -> [Prop PName] -> Located [Prop PName]
forall a. Range -> a -> Located a
Located Range
r ([Prop PName] -> Located [Prop PName])
-> ParseM [Prop PName] -> ParseM (Located [Prop PName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Range -> Type PName -> ParseM [Prop PName]
forall n. Range -> Type n -> ParseM [Prop n]
props Range
r Type PName
t
    Type PName
_            -> String -> [String] -> ParseM (Located [Prop PName])
forall a. HasCallStack => String -> [String] -> a
panic String
"Parser" [ String
"Invalid type given to mkProp"
                                   , String
"expected a location"
                                   , Type PName -> String
forall a. Show a => a -> String
show Type PName
ty ]

  where

  props :: Range -> Type n -> ParseM [Prop n]
props Range
r Type n
t =
    case Type n
t of
      TInfix{}       -> [Prop n] -> ParseM [Prop n]
forall (m :: * -> *) a. Monad m => a -> m a
return [Type n -> Prop n
forall n. Type n -> Prop n
CType Type n
t]
      TUser{}        -> [Prop n] -> ParseM [Prop n]
forall (m :: * -> *) a. Monad m => a -> m a
return [Type n -> Prop n
forall n. Type n -> Prop n
CType Type n
t]
      TTuple [Type n]
ts      -> [[Prop n]] -> [Prop n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Prop n]] -> [Prop n]) -> ParseM [[Prop n]] -> ParseM [Prop n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Type n -> ParseM [Prop n]) -> [Type n] -> ParseM [[Prop n]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Range -> Type n -> ParseM [Prop n]
props Range
r) [Type n]
ts
      TParens Type n
t'     -> Range -> Type n -> ParseM [Prop n]
props Range
r  Type n
t'
      TLocated Type n
t' Range
r' -> Range -> Type n -> ParseM [Prop n]
props Range
r' Type n
t'

      TFun{}    -> ParseM [Prop n]
forall a. ParseM a
err
      TSeq{}    -> ParseM [Prop n]
forall a. ParseM a
err
      TBit{}    -> ParseM [Prop n]
forall a. ParseM a
err
      TNum{}    -> ParseM [Prop n]
forall a. ParseM a
err
      TChar{}   -> ParseM [Prop n]
forall a. ParseM a
err
      Type n
TWild     -> ParseM [Prop n]
forall a. ParseM a
err
      TRecord{} -> ParseM [Prop n]
forall a. ParseM a
err
      TTyApp{}  -> ParseM [Prop n]
forall a. ParseM a
err

    where
    err :: ParseM a
err = Range -> [String] -> ParseM a
forall a. Range -> [String] -> ParseM a
errorMessage Range
r [String
"Invalid constraint"]

-- | Make an ordinary module
mkModule :: Located ModName -> [TopDecl PName] -> Module PName
mkModule :: Located ModName -> [TopDecl PName] -> Module PName
mkModule Located ModName
nm [TopDecl PName]
ds = Module :: forall mname name.
Located mname
-> Maybe (Located ModName) -> [TopDecl name] -> ModuleG mname name
Module { mName :: Located ModName
mName = Located ModName
nm
                        , mInstance :: Maybe (Located ModName)
mInstance = Maybe (Located ModName)
forall a. Maybe a
Nothing
                        , mDecls :: [TopDecl PName]
mDecls = [TopDecl PName]
ds
                        }

mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested Module PName
m =
  case ModName -> [String]
modNameChunks (Located ModName -> ModName
forall a. Located a -> a
thing Located ModName
nm) of
    [String
c] -> NestedModule PName -> ParseM (NestedModule PName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleG PName PName -> NestedModule PName
forall name. ModuleG name name -> NestedModule name
NestedModule Module PName
m { mName :: LPName
mName = Located ModName
nm { thing :: PName
thing = Ident -> PName
mkUnqual (String -> Ident
packIdent String
c)}})
    [String]
_   -> Range -> [String] -> ParseM (NestedModule PName)
forall a. Range -> [String] -> ParseM a
errorMessage Range
r
                [String
"Nested modules names should be a simple identifier."]
  where
  nm :: Located ModName
nm = Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
mName Module PName
m
  r :: Range
r = Located ModName -> Range
forall a. Located a -> Range
srcRange Located ModName
nm

-- | Make an unnamed module---gets the name @Main@.
mkAnonymousModule :: [TopDecl PName] -> Module PName
mkAnonymousModule :: [TopDecl PName] -> Module PName
mkAnonymousModule = Located ModName -> [TopDecl PName] -> Module PName
mkModule Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
emptyRange
                                     , thing :: ModName
thing    = [Text] -> ModName
mkModName [String -> Text
T.pack String
"Main"]
                                     }

-- | Make a module which defines a functor instance.
mkModuleInstance :: Located ModName ->
                    Located ModName ->
                    [TopDecl PName] ->
                    Module PName
mkModuleInstance :: Located ModName
-> Located ModName -> [TopDecl PName] -> Module PName
mkModuleInstance Located ModName
nm Located ModName
fun [TopDecl PName]
ds =
  Module :: forall mname name.
Located mname
-> Maybe (Located ModName) -> [TopDecl name] -> ModuleG mname name
Module { mName :: Located ModName
mName     = Located ModName
nm
         , mInstance :: Maybe (Located ModName)
mInstance = Located ModName -> Maybe (Located ModName)
forall a. a -> Maybe a
Just Located ModName
fun
         , mDecls :: [TopDecl PName]
mDecls    = [TopDecl PName]
ds
         }

ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed (UpdField UpdHow
h [Located Selector]
ls Expr PName
e) =
  case (UpdHow
h,[Located Selector]
ls) of
    (UpdHow
UpdSet, [Located Selector
l]) | RecordSel Ident
i Maybe [Ident]
Nothing <- Located Selector -> Selector
forall a. Located a -> a
thing Located Selector
l ->
      Named (Expr PName) -> ParseM (Named (Expr PName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Named :: forall a. Located Ident -> a -> Named a
Named { name :: Located Ident
name = Located Selector
l { thing :: Ident
thing = Ident
i }, value :: Expr PName
value = Expr PName
e }
    (UpdHow, [Located Selector])
_ -> Range -> [String] -> ParseM (Named (Expr PName))
forall a. Range -> [String] -> ParseM a
errorMessage (Located Selector -> Range
forall a. Located a -> Range
srcRange ([Located Selector] -> Located Selector
forall a. [a] -> a
head [Located Selector]
ls))
            [String
"Invalid record field.  Perhaps you meant to update a record?"]

exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath Expr PName
e0 = [Located Selector] -> [Located Selector]
forall a. [a] -> [a]
reverse ([Located Selector] -> [Located Selector])
-> ParseM [Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range -> Expr PName -> ParseM [Located Selector]
go Range
forall a. a
noLoc Expr PName
e0
  where
  noLoc :: a
noLoc = String -> [String] -> a
forall a. HasCallStack => String -> [String] -> a
panic String
"selExprToSels" [String
"Missing location?"]
  go :: Range -> Expr PName -> ParseM [Located Selector]
go Range
loc Expr PName
expr =
    case Expr PName
expr of
      ELocated Expr PName
e1 Range
r -> Range -> Expr PName -> ParseM [Located Selector]
go Range
r Expr PName
e1
      ESel Expr PName
e2 Selector
s ->
        do [Located Selector]
ls <- Range -> Expr PName -> ParseM [Located Selector]
go Range
loc Expr PName
e2
           let rng :: Range
rng = Range
loc { from :: Position
from = Range -> Position
to (Located Selector -> Range
forall a. Located a -> Range
srcRange ([Located Selector] -> Located Selector
forall a. [a] -> a
head [Located Selector]
ls)) }
           [Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing = Selector
s, srcRange :: Range
srcRange = Range
rng } Located Selector -> [Located Selector] -> [Located Selector]
forall a. a -> [a] -> [a]
: [Located Selector]
ls)
      EVar (UnQual Ident
l) ->
        [Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing = Ident -> Maybe [Ident] -> Selector
RecordSel Ident
l Maybe [Ident]
forall a. Maybe a
Nothing, srcRange :: Range
srcRange = Range
loc } ]

      ELit (ECNum Integer
n (DecLit {})) ->
        [Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing = Int -> Maybe Int -> Selector
TupleSel (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) Maybe Int
forall a. Maybe a
Nothing
                       , srcRange :: Range
srcRange = Range
loc } ]

      ELit (ECFrac Rational
_ (DecFrac Text
txt))
        | (Text
as,Text
bs') <- (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
txt
        , Just Int
a <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
as)
        , Just (Char
_,Text
bs) <- Text -> Maybe (Char, Text)
T.uncons Text
bs'
        , Just Int
b <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
bs)
        , let fromP :: Position
fromP = Range -> Position
from Range
loc
        , let midP :: Position
midP  = Position
fromP { col :: Int
col = Position -> Int
col Position
fromP Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
as Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 } ->
          -- these are backward because we reverse above
          [Located Selector] -> ParseM [Located Selector]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing    = Int -> Maybe Int -> Selector
TupleSel Int
b Maybe Int
forall a. Maybe a
Nothing
                         , srcRange :: Range
srcRange = Range
loc { from :: Position
from = Position
midP }
                         }
               , Located :: forall a. Range -> a -> Located a
Located { thing :: Selector
thing    = Int -> Maybe Int -> Selector
TupleSel Int
a Maybe Int
forall a. Maybe a
Nothing
                         , srcRange :: Range
srcRange = Range
loc { to :: Position
to = Position
midP }
                         }
               ]

      Expr PName
_ -> Range -> [String] -> ParseM [Located Selector]
forall a. Range -> [String] -> ParseM a
errorMessage Range
loc [String
"Invalid label in record update."]


mkSelector :: Token -> Selector
mkSelector :: Token -> Selector
mkSelector Token
tok =
  case Token -> TokenT
tokenType Token
tok of
    Selector (TupleSelectorTok Int
n) -> Int -> Maybe Int -> Selector
TupleSel Int
n Maybe Int
forall a. Maybe a
Nothing
    Selector (RecordSelectorTok Text
t) -> Ident -> Maybe [Ident] -> Selector
RecordSel (Text -> Ident
mkIdent Text
t) Maybe [Ident]
forall a. Maybe a
Nothing
    TokenT
_ -> String -> [String] -> Selector
forall a. HasCallStack => String -> [String] -> a
panic String
"mkSelector"
          [ String
"Unexpected selector token", Token -> String
forall a. Show a => a -> String
show Token
tok ]