-- |
-- 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 #-}
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.LexerUtils(SelectorType(..))
import Cryptol.Parser.Position
import Cryptol.Parser.Utils (translateExprToNumT,widthIdent)
import Cryptol.Utils.Ident(packModName)
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)
        ]
      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
nest 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
nest 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
nest 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) =
  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
nest Int
2 Doc
unexp Doc -> Doc -> Doc
$$
   Int -> Doc -> Doc
nest Int
2 (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 -> (Doc
empty,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 -> ParseM a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: 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
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
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."]

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 }

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 td :: TopDecl name
td@Include{}  = 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 = Bind PName -> Decl PName
forall name. Bind name -> Decl name
DBind Bind :: forall name.
Located name
-> [Pattern name]
-> Located (BindDef name)
-> Maybe (Schema name)
-> Bool
-> Maybe Fixity
-> [Pragma]
-> Bool
-> Maybe Text
-> Bind name
Bind { bName :: 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
                               }

-- 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
-> 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
             }
  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
-> 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
                 }
  , 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 ->
            ([Located Import], [TopDecl PName]) ->
            Module PName
mkModule :: Located ModName
-> ([Located Import], [TopDecl PName]) -> Module PName
mkModule Located ModName
nm ([Located Import]
is,[TopDecl PName]
ds) = Module :: forall name.
Located ModName
-> Maybe (Located ModName)
-> [Located Import]
-> [TopDecl name]
-> Module name
Module { mName :: Located ModName
mName = Located ModName
nm
                             , mInstance :: Maybe (Located ModName)
mInstance = Maybe (Located ModName)
forall a. Maybe a
Nothing
                             , mImports :: [Located Import]
mImports = [Located Import]
is
                             , mDecls :: [TopDecl PName]
mDecls = [TopDecl PName]
ds
                             }

-- | Make an unnamed module---gets the name @Main@.
mkAnonymousModule :: ([Located Import], [TopDecl PName]) ->
                     Module PName
mkAnonymousModule :: ([Located Import], [TopDecl PName]) -> Module PName
mkAnonymousModule = Located ModName
-> ([Located Import], [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 ->
                    ([Located Import], [TopDecl PName]) ->
                    Module PName
mkModuleInstance :: Located ModName
-> Located ModName
-> ([Located Import], [TopDecl PName])
-> Module PName
mkModuleInstance Located ModName
nm Located ModName
fun ([Located Import]
is,[TopDecl PName]
ds) =
  Module :: forall name.
Located ModName
-> Maybe (Located ModName)
-> [Located Import]
-> [TopDecl name]
-> Module 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
         , mImports :: [Located Import]
mImports  = [Located Import]
is
         , 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 ]