-- |
-- 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 PatternSynonyms #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Cryptol.Parser.ParserUtils where

import Data.Char(isAlphaNum, isSpace)
import Data.Maybe(fromMaybe, mapMaybe)
import Data.Bits(testBit,setBit)
import Data.List(foldl')
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Control.Monad(liftM,ap,unless,guard,msum)
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 Data.Foldable (for_)

import GHC.Generics (Generic)
import Control.DeepSeq

import Prelude ()
import Prelude.Compat


import Cryptol.Parser.AST
import Cryptol.Parser.Lexer
import Cryptol.Parser.Token(SelectorType(..))
import Cryptol.Parser.Position
import Cryptol.Parser.Utils (translateExprToNumT,widthIdent)
import Cryptol.Utils.Ident( packModName,packIdent,modNameChunks
                          , identAnonArg, identAnonIfaceMod, identAnonInstImport
                          , modNameArg, modNameIfaceMod
                          , mainModName, modNameIsNormal
                          , modNameToNormalModName
                          , unpackIdent, isUpperIdent
                          )
import Cryptol.Utils.PP
import Cryptol.Utils.Panic
import Cryptol.Utils.RecordMap
import Cryptol.Parser.Name (pattern UnQual, mkUnqualSystem)


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

parse :: Config -> ParseM a -> Text -> Either ParseError a
parse cfg p cs    = case unP p cfg eofPos S { sPrevTok = Nothing
                                            , sTokens = toks
                                            , sNextTyParamNum = 0
                                            } of
                      Left err    -> Left err
                      Right (a,_) -> Right a
  where (toks,eofPos) = lexer cfg cs


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

askConfig :: ParseM Config
askConfig = P \cfg _ s -> Right (cfg, s)

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

    t : more -> unP (k t) cfg p s { sPrevTok = Just t, sTokens = more }
    [] -> Left (HappyOutOfTokens (cfgSource cfg) 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 (Show, Generic, NFData)

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

ppError :: ParseError -> Doc

ppError (HappyError path ltok)
  | Err _ <- tokenType tok =
    text "Parse error at" <+>
    text path <.> char ':' <.> pp pos <.> comma <+>
    pp tok

  | White DocStr <- tokenType tok =
    "Unexpected documentation (/**) comment at" <+>
    text path <.> char ':' <.> pp pos <.> colon $$
    indent 2
      "Documentation comments need to be followed by something to document."

  | otherwise =
    text "Parse error at" <+>
    text path <.> char ':' <.> pp pos <.> comma $$
    indent 2 (text "unexpected:" <+> pp tok)
  where
  pos = from (srcRange ltok)
  tok = thing ltok

ppError (HappyOutOfTokens path pos) =
  text "Unexpected end of file at:" <+>
    text path <.> char ':' <.> pp pos

ppError (HappyErrorMsg p xs)  = text "Parse error at" <+> pp p $$ indent 2 (vcat (map text xs))

ppError (HappyUnexpected path ltok e) =
  nest 2 $ vcat $
   [ text "Parse error at" <+> text path <.> char ':' <.> pp pos <.> comma ]
   ++ unexp
   ++ ["expected:" <+> text e]
  where
  (unexp,pos) =
    case ltok of
      Nothing -> ( [] ,start)
      Just t  -> ( ["unexpected:" <+> text (T.unpack (tokenText (thing t)))]
                 , from (srcRange t)
                 )

instance Functor ParseM where
  fmap = liftM

instance Applicative ParseM where
  pure a = P (\_ _ s -> Right (a,s))
  (<*>) = ap

instance Monad ParseM where
  return    = pure
  m >>= k   = P (\cfg p s1 -> case unP m cfg p s1 of
                            Left e       -> Left e
                            Right (a,s2) -> unP (k a) cfg p s2)

instance Fail.MonadFail ParseM where
  fail s    = panic "[Parser] fail" [s]

happyError :: ParseM a
happyError = P $ \cfg _ s ->
  case sPrevTok s of
    Just t  -> Left (HappyError (cfgSource cfg) t)
    Nothing ->
      Left (HappyErrorMsg emptyRange ["Parse error at the beginning of the file"])

errorMessage :: Range -> [String] -> ParseM a
errorMessage r xs = P $ \_ _ _ -> Left (HappyErrorMsg r xs)

customError :: String -> Located Token -> ParseM a
customError x t = P $ \_ _ _ -> Left (HappyErrorMsg (srcRange t) [x])

expected :: String -> ParseM a
expected x = P $ \cfg _ s ->
                    Left (HappyUnexpected (cfgSource cfg) (sPrevTok s) x)

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

-- | This is how we derive the name of a module parameter from the
-- @import source@ declaration.
mkModParamName :: Located (ImpName PName) -> Maybe (Located ModName) -> Ident
mkModParamName lsig qual =
  case qual of
    Nothing ->
      case thing lsig of
        ImpTop t
          | modNameIsNormal t -> packIdent (last (modNameChunks t))
          | otherwise         -> identAnonIfaceMod
                               $ packIdent
                               $ last
                               $ modNameChunks
                               $ modNameToNormalModName t
        ImpNested nm ->
          case nm of
            UnQual' i _ -> i
            Qual _ i -> i
            NewName {} -> panic "mkModParamName" ["Unexpected NewName",show lsig]
    Just m -> packIdent (last (modNameChunks (thing m)))

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

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

getNum :: Located Token -> Integer
getNum l = case thing l of
             Token (Num x _ _) _ -> x
             Token (ChrLit x) _  -> toInteger (fromEnum x)
             _ -> panic "[Parser] getNum" ["not a number:", show l]

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

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

numLit :: Token -> Expr PName
numLit Token { tokenText = txt, tokenType = Num x base digs }
  | base == 2   = ELit $ ECNum x (BinLit txt digs)
  | base == 8   = ELit $ ECNum x (OctLit txt digs)
  | base == 10  = ELit $ ECNum x (DecLit txt)
  | base == 16  = ELit $ ECNum x (HexLit txt digs)

numLit x = panic "[Parser] numLit" ["invalid numeric literal", show x]

fracLit :: Token -> Expr PName
fracLit tok =
  case tokenType tok of
    Frac x base
      | base == 2   -> ELit $ ECFrac x $ BinFrac $ tokenText tok
      | base == 8   -> ELit $ ECFrac x $ OctFrac $ tokenText tok
      | base == 10  -> ELit $ ECFrac x $ DecFrac $ tokenText tok
      | base == 16  -> ELit $ ECFrac x $ HexFrac $ tokenText tok
    _ -> panic "[Parser] fracLit" [ "Invalid fraction", show tok ]


intVal :: Located Token -> ParseM Integer
intVal tok =
  case tokenType (thing tok) of
    Num x _ _ -> return x
    _         -> errorMessage (srcRange tok) ["Expected an integer"]

mkFixity :: Assoc -> Located Token -> [LPName] -> ParseM (Decl PName)
mkFixity assoc tok qns =
  do l <- intVal tok
     unless (l >= 1 && l <= 100)
          (errorMessage (srcRange tok) ["Fixity levels must be between 1 and 100"])
     return (DFixity (Fixity assoc (fromInteger l)) qns)

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


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

    TParens t mb -> case mb of
                      Nothing -> validDemotedType rng t
                      Just _  -> bad "kind annotation"
    TInfix{}     -> ok

  where bad x = errorMessage rng [x ++ " cannot be demoted."]
        ok    = return $ at rng ty

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

  where
  res = recordFromFieldsErr ys
  ys = map (\ (Named (Located r nm) x) -> (nm,(r,x))) (reverse xs)


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

mkEApp es@(eLast :| _) =
    do f :| xs <- cvtTypeParams eFirst rest
       pure (at (eFirst,eLast) $ foldl EApp f xs)

  where
  eFirst :| rest = NE.reverse 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 e [] = pure (e :| [])
  cvtTypeParams e (p : ps) =
    case toTypeParam p Nothing of
      Nothing -> NE.cons e <$> cvtTypeParams p ps

      Just (fs,ss,rng) ->
        if checkAppExpr e then
          let e'  = foldr (flip ESel) (EAppT e fs) ss
              e'' = case rCombMaybe (getLoc e) rng of
                      Just r -> ELocated e' r
                      Nothing -> e'
           in cvtTypeParams e'' ps
        else
          errorMessage (fromMaybe emptyRange (getLoc e))
                  [ "Explicit type applications can only be applied to named values."
                  , "Unexpected: " ++ show (pp 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 e =
    case e of
      ELocated e' _ -> checkAppExpr e'
      EParens e'    -> checkAppExpr e'
      EVar{}        -> True
      _             -> 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 e mr =
    case e of
      ELocated e' rng -> toTypeParam e' (rCombMaybe mr (Just rng))
      ETypeVal t -> toTypeParam' t mr
      ESel e' s  -> ( \(fs,ss,r) -> (fs,s:ss,r) ) <$> toTypeParam e' mr
      _          ->  Nothing

  toTypeParam' t mr =
    case t of
      TLocated t' rng -> toTypeParam' t' (rCombMaybe mr (Just rng))
      TTyApp fs -> Just (map mkTypeInst fs, [], mr)
      _ -> Nothing

unOp :: Expr PName -> Expr PName -> Expr PName
unOp f x = at (f,x) $ EApp f x

-- Use defaultFixity as a placeholder, it will be fixed during renaming.
binOp :: Expr PName -> Located PName -> Expr PName -> Expr PName
binOp x f y = at (x,y) $ EInfix x f defaultFixity 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 r e1 e2 e3 =
  case (asETyped e1, asETyped =<< e2, asETyped e3) of
    (Just (e1', t), Nothing, Nothing) -> eFromToType r e1' e2 e3 (Just t)
    (Nothing, Just (e2', t), Nothing) -> eFromToType r e1 (Just e2') e3 (Just t)
    (Nothing, Nothing, Just (e3', t)) -> eFromToType r e1 e2 e3' (Just t)
    (Nothing, Nothing, Nothing) -> eFromToType r e1 e2 e3 Nothing
    _ -> errorMessage r ["A sequence enumeration may have at most one element type annotation."]

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

eFromToByTyped :: Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName)
eFromToByTyped r e1 e2 e3 t isStrictBound =
  EFromToBy isStrictBound
      <$> exprToNumT r e1
      <*> exprToNumT r e2
      <*> exprToNumT r e3
      <*> pure t

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

eFromToDownByTyped ::
  Range -> Expr PName -> Expr PName -> Expr PName -> Maybe (Type PName) -> Bool -> ParseM (Expr PName)
eFromToDownByTyped r e1 e2 e3 t isStrictBound =
  EFromToDownBy isStrictBound
      <$> exprToNumT r e1
      <*> exprToNumT r e2
      <*> exprToNumT r e3
      <*> pure t


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

eFromToType ::
  Range -> Expr PName -> Maybe (Expr PName) -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToType r e1 e2 e3 t =
  EFromTo <$> exprToNumT r e1
          <*> mapM (exprToNumT r) e2
          <*> exprToNumT r e3
          <*> pure t

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

eFromToLessThanType ::
  Range -> Expr PName -> Expr PName -> Maybe (Type PName) -> ParseM (Expr PName)
eFromToLessThanType r e1 e2 t =
  EFromToLessThan
    <$> exprToNumT r e1
    <*> exprToNumT r e2
    <*> pure t

exprToNumT :: Range -> Expr PName -> ParseM (Type PName)
exprToNumT r expr =
  case translateExprToNumT r expr of
    Just t -> return t
    Nothing -> bad
  where
  bad = errorMessage (fromMaybe r (getLoc expr))
        [ "The boundaries of .. sequences should be valid numeric types."
        , "The expression `" ++ show (pp expr) ++ "` 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 ~(Just r) ts = TLocated (TTyApp (map toField ts)) r
  where noName    = Located { srcRange = r, thing = mkIdent (T.pack "") }
        toField t = Named { name = noName, value = t }

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

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

exportEnum ::
  ExportType -> Maybe (Located Text) -> EnumDecl PName -> TopDecl PName
exportEnum e d n = TDEnum TopLevel { tlExport = e
                                   , tlDoc = d
                                   , tlValue = n }

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

mkParFun :: Maybe (Located Text) ->
            Located PName ->
            Schema PName ->
            ParamDecl PName
mkParFun mbDoc n s = DParameterFun ParameterFun { pfName = n
                                                , pfSchema = s
                                                , pfDoc = mbDoc
                                                , pfFixity = Nothing
                                                }

mkParType :: Maybe (Located Text) ->
             Located PName ->
             Located Kind ->
             ParseM (ParamDecl PName)
mkParType mbDoc n k =
  do num <- P $ \_ _ s -> let nu = sNextTyParamNum s
                          in Right (nu, s { sNextTyParamNum = nu + 1 })
     return (DParameterType
             ParameterType { ptName    = n
                           , ptKind    = thing k
                           , ptDoc     = mbDoc
                           , ptFixity  = Nothing
                           , ptNumber  = num
                           })

changeExport :: ExportType -> [TopDecl PName] -> [TopDecl PName]
changeExport e = map change
  where
  change decl =
    case decl of
      Decl d                  -> Decl      d { tlExport = e }
      DPrimType t             -> DPrimType t { tlExport = e }
      TDNewtype n             -> TDNewtype n { tlExport = e }
      TDEnum n                -> TDEnum    n { tlExport = e }
      DModule m               -> DModule   m { tlExport = e }
      DModParam {}            -> decl
      Include{}               -> decl
      DImport{}               -> decl
      DParamDecl{}            -> decl
      DInterfaceConstraint {} -> decl

addDeclDocstring :: Located Text -> TopDecl name -> ParseM (TopDecl name)
addDeclDocstring doc decl =
  case decl of
    Decl d -> Decl  <$> topLevel d
    DPrimType t -> DPrimType <$> topLevel t
    TDNewtype n -> TDNewtype <$> topLevel n
    TDEnum n -> TDEnum <$> topLevel n
    DModule m -> DModule <$> topLevel m
    DModParam p -> pure (DModParam p { mpDoc = Just doc })
    Include _ -> failure "Docstring on include"
    DImport i -> DImport <$> traverse imp i
    DInterfaceConstraint Nothing x -> pure (DInterfaceConstraint (Just doc) x)
    DInterfaceConstraint Just{} _ -> failure "Overlapping docstring"
    DParamDecl{} -> failure "Docstring on parameter declarations"
  where
    failure e = errorMessage (fromMaybe emptyRange (getLoc decl)) [e]
    imp i =
      case iDoc i of
        Nothing -> pure i { iDoc = Just doc }
        Just{}  -> failure "Overlapping docstring"
    topLevel x =
      case tlDoc x of
        Just _ -> failure "Overlapping docstring"
        Nothing -> pure x { tlDoc = Just doc }

privateDocedDecl :: Located Text -> [TopDecl PName] -> ParseM [TopDecl PName]
privateDocedDecl doc (decl:decls) = fmap (: decls) (addDeclDocstring doc decl)
privateDocedDecl doc [] = errorMessage (srcRange doc) ["Docstring on empty private section"]

mkTypeInst :: Named (Type PName) -> TypeInst PName
mkTypeInst x | nullIdent (thing (name x)) = PosInst (value x)
             | otherwise                  = NamedInst x

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


mkTySyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkTySyn thead tdef =
  do (nm,params) <- typeToDecl thead
     pure (DType (TySyn nm Nothing params tdef))

mkPropSyn :: Type PName -> Type PName -> ParseM (Decl PName)
mkPropSyn thead tdef =
  do (nm,params) <- typeToDecl thead
     ps          <- thing <$> mkProp tdef
     pure (DProp (PropSyn nm Nothing params ps))

mkNewtype ::
  Type PName ->
  Located (RecordMap Ident (Range, Type PName)) ->
  [Located PName] ->
  ParseM (Newtype PName)
mkNewtype thead def derivs =
  do (nm,params) <- typeToDecl thead
     pure (Newtype nm params (thing nm) (thing def) derivs)

mkEnumDecl ::
  Type PName ->
  [ TopLevel (EnumCon PName) ] {- ^ Reversed -} ->
  [Located PName] ->
  ParseM (EnumDecl PName)
mkEnumDecl thead def derivs =
  do (nm,params) <- typeToDecl thead
     mapM_ reportRepeated
        (Map.toList (Map.fromListWith (++) [ (thing k,[srcRange k])
                                           | k <- map (ecName . tlValue) def ]))
     pure EnumDecl
            { eName     = nm
            , eParams   = params
            , eCons     = reverse def
            , eDeriving = derivs
            }
  where
  reportRepeated (i,xs) =
    case xs of
      l : ls@(_ : _) ->
        errorMessage l
          ( ("Multiple declarations for " ++ show (backticks (pp i)))
          : [ "Other declaration: " ++ show (pp x) | x <- ls ]
          )

      _ -> pure ()

-- | This function handles constructor declarations
mkConDecl ::
  Maybe (Located Text) -> ExportType ->
  Type PName -> ParseM (TopLevel (EnumCon PName))
mkConDecl mbDoc expT ty =
  do con <- go Nothing ty
     pure TopLevel { tlExport = expT, tlDoc = mbDoc, tlValue = con }
  where
  go mbLoc t =
    case t of
      TLocated t1 r -> go (Just r) t1
      TUser n ts ->
        case thing n of
          UnQual' i ns 
            | isUpperIdent i ->
              pure EnumCon { ecName = Located (srcRange n) (UnQual' i ns)
                           , ecFields = ts
                           }
            | otherwise ->
              errorMessage (getL mbLoc)
                 [ "Malformed constructor declaration."
                 , "The constructor name should start with a capital letter."
                 ]

          _ -> errorMessage (getL mbLoc)
                 [ "Malformed constructor declaration."
                 , "The constructor name may not be qualified."
                 ]
      _ -> errorMessage (getL mbLoc) [ "Malformed constructor declaration." ]

  getL mb =
    case mb of
      Just r  -> r
      Nothing -> panic "mkConDecl" ["Missing type location"]


typeToDecl :: Type PName -> ParseM (Located PName, [TParam PName])
typeToDecl ty0 =
  case ty0 of
    TLocated ty loc -> goD loc ty
    _ -> panic "typeToDecl" ["Type location is missing."]

  where
  bad loc  = errorMessage loc ["Invalid type declaration"]
  badP loc = errorMessage loc ["Invalid declaration parameter"]


  goN loc n =
    case n of
      UnQual {} -> pure ()
      _         -> errorMessage loc ["Invalid declaration name"]

  goP loc ty =
    case ty of
      TLocated ty1 loc1 -> goP loc1 ty1

      TUser f [] ->
        do goN (srcRange f) (thing f)
           pure TParam { tpName = thing f, tpKind = Nothing, tpRange = Just loc }

      TParens t mb ->
        case mb of
          Nothing -> badP loc
          Just k  ->
            do p <- goP loc t
               case tpKind p of
                 Nothing -> pure p { tpKind = Just k }
                 Just {} -> badP loc

      TInfix {}     -> badP loc
      TUser {}      -> badP loc
      TFun {}       -> badP loc
      TSeq {}       -> badP loc
      TBit {}       -> badP loc
      TNum {}       -> badP loc
      TChar {}      -> badP loc
      TRecord {}    -> badP loc
      TWild {}      -> badP loc
      TTyApp {}     -> badP loc
      TTuple {}     -> badP loc

  
  goD loc ty =
    case ty of

      TLocated ty1 loc1 -> goD loc1 ty1

      TUser f ts ->
        do goN (srcRange f) (thing f)
           ps <- mapM (goP loc) ts
           pure (f,ps)

      TInfix l f _ r ->
        do goN (srcRange f) (thing f)
           a  <- goP loc l
           b  <- goP loc r
           pure (f,[a,b])

      TFun {}       -> bad loc
      TSeq {}       -> bad loc
      TBit {}       -> bad loc
      TNum {}       -> bad loc
      TChar {}      -> bad loc
      TRecord {}    -> bad loc
      TWild {}      -> bad loc
      TTyApp {}     -> bad loc
      TTuple {}     -> bad loc
      TParens {}    -> bad loc

polyTerm :: Range -> Integer -> Integer -> ParseM (Bool, Integer)
polyTerm rng k p
  | k == 0          = return (False, p)
  | k == 1          = return (True, p)
  | otherwise       = errorMessage rng ["Invalid polynomial coefficient"]

mkPoly :: Range -> [ (Bool,Integer) ] -> ParseM (Expr PName)
mkPoly rng terms
  | w <= toInteger (maxBound :: Int) = mk 0 (map fromInteger bits)
  | otherwise = errorMessage rng ["Polynomial literal too large: " ++ show w]

  where
  w    = case terms of
           [] -> 0
           _  -> 1 + maximum (map snd terms)

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

  mk :: Integer -> [Int] -> ParseM (Expr PName)
  mk res [] = return $ ELit $ ECNum res (PolyLit (fromInteger w :: Int))

  mk res (n : ns)
    | testBit res n = errorMessage rng
                       ["Polynomial contains multiple terms with exponent " ++ show n]
    | otherwise     = mk (setBit res n) ns


-- NOTE: The list of patterns is reversed!
mkProperty :: LPName -> [Pattern PName] -> Expr PName -> Decl PName
mkProperty f ps e = at (f,e) $
                    DBind Bind { bName       = f
                               , bParams     = PatternParams (reverse ps)
                               , bDef        = at e (Located emptyRange (exprDef e))
                               , bSignature  = Nothing
                               , bPragmas    = [PragmaProperty]
                               , bMono       = False
                               , bInfix      = False
                               , bFixity     = Nothing
                               , bDoc        = Nothing
                               , bExport     = Public
                               }

-- NOTE: The lists of patterns are reversed!
mkIndexedDecl ::
  LPName -> ([Pattern PName], [Pattern PName]) -> Expr PName -> Decl PName
mkIndexedDecl f (ps, ixs) e =
  DBind Bind { bName       = f
             , bParams     = PatternParams (reverse ps)
             , bDef        = at e (Located emptyRange (exprDef rhs))
             , bSignature  = Nothing
             , bPragmas    = []
             , bMono       = False
             , bInfix      = False
             , bFixity     = Nothing
             , bDoc        = Nothing
             , bExport     = Public
             }
  where
    rhs :: Expr PName
    rhs = mkGenerate (reverse ixs) e

-- NOTE: The lists of patterns are reversed!
mkPropGuardsDecl ::
  LPName ->
  ([Pattern PName], [Pattern PName]) ->
  [PropGuardCase PName] ->
  ParseM (Decl PName)
mkPropGuardsDecl f (ps, ixs) guards =
  do unless (null ixs) $
      errorMessage (srcRange f)
                  ["Indexed sequence definitions may not use constraint guards"]
     let gs  = reverse guards
     pure $
       DBind Bind { bName       = f
                  , bParams     = PatternParams (reverse ps)
                  , bDef        = Located (srcRange f) (DImpl (DPropGuards gs))
                  , bSignature  = Nothing
                  , bPragmas    = []
                  , bMono       = False
                  , bInfix      = False
                  , bFixity     = Nothing
                  , bDoc        = Nothing
                  , bExport     = Public
                  }

mkConstantPropGuardsDecl ::
  LPName -> [PropGuardCase PName] -> ParseM (Decl PName)
mkConstantPropGuardsDecl f guards =
  mkPropGuardsDecl f ([],[]) guards

-- NOTE: The lists of patterns are reversed!
mkIndexedExpr :: ([Pattern PName], [Pattern PName]) -> Expr PName -> Expr PName
mkIndexedExpr (ps, ixs) body
  | null ps = mkGenerate (reverse ixs) body
  | otherwise = EFun emptyFunDesc (reverse ps) (mkGenerate (reverse ixs) body)

mkGenerate :: [Pattern PName] -> Expr PName -> Expr PName
mkGenerate pats body =
  foldr (\pat e -> EGenerate (EFun emptyFunDesc [pat] e)) body pats

mkIf :: [(Expr PName, Expr PName)] -> Expr PName -> Expr PName
mkIf ifThens theElse = foldr addIfThen theElse ifThens
    where
    addIfThen (cond, doexpr) elseExpr = EIf cond doexpr elseExpr

mkPVar :: Located PName -> Pattern PName
mkPVar p =
  case thing p of
    UnQual i | isInfixIdent i || not (isUpperIdent i) -> PVar p
    _ -> PCon p []

mkIPat :: Pattern PName -> ParseM (Pattern PName)
mkIPat pat =
  case pat of
    PVar {}      -> pure pat
    PWild        -> pure pat
    PTuple ps    -> PTuple <$> traverse mkIPat ps
    PRecord rp   -> PRecord <$> traverseRecordMap upd rp
      where upd _ (x,y) = (,) x <$> mkIPat y
    PList ps     -> PList <$> traverse mkIPat ps
    PTyped p t   -> (`PTyped` t) <$> mkIPat p
    PSplit p1 p2 -> PSplit <$> mkIPat p1 <*> mkIPat p2
    PLocated p r -> (`PLocated` r) <$> mkIPat p
    PCon n ps    ->
      case ps of
        [] | UnQual {} <- thing n -> pure (PVar n)
        _ -> errorMessage (srcRange n)
               [ "Unexpected constructor pattern."
               , "Constructors patterns may be used only in `case` expressions."
               ]



mkPrimDecl :: Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkPrimDecl = mkNoImplDecl DPrim

mkForeignDecl ::
  Maybe (Located Text) -> Maybe LPName -> LPName -> Schema PName -> ParseM [TopDecl PName]
mkForeignDecl mbDoc mbCC nm ty =
  do let txt = unpackIdent (getIdent (thing nm))
     fgn <- case mbCC of
              Nothing -> pure ForeignC
              Just cc ->
                case thing cc of
                  UnQual i
                     | tx == "c" -> pure ForeignC
                     | tx == "abstract" -> pure ForeignAbstract
                     where tx = identText i
                  _ -> errorMessage (srcRange cc)
                          [ "Invalid calling convention."
                          , "We support `c` and `abstract` at present."
                          ]
     unless (all isOk txt)
       (errorMessage (srcRange nm)
            [ "`" ++ txt ++ "` is not a valid foreign name."
            , "The name should contain only alpha-numeric characters or '_'."
            ])
     -- We do allow optional cryptol implementations of foreign functions, these
     -- will be merged with this binding in the NoPat pass. In the parser they
     -- are just treated as a completely separate (non-foreign) binding with the
     -- same name.
     pure (mkNoImplDecl (DForeign fgn Nothing) mbDoc nm ty)
  where
  isOk c = c == '_' || isAlphaNum c

-- | Generate a signature and a binding for value declarations with no
-- implementation (i.e. primitive or foreign declarations).  The reason for
-- generating both instead of just adding the signature at this point is that it
-- means the 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 and foreigns.
mkNoImplDecl :: BindDef PName
  -> Maybe (Located Text) -> LPName -> Schema PName -> [TopDecl PName]
mkNoImplDecl def mbDoc ln sig =
  [ exportDecl Nothing Public
    $ DBind Bind { bName      = ln
                 , bParams    = noParams
                 , bDef       = at sig (Located emptyRange def)
                 , bSignature = Nothing
                 , bPragmas   = []
                 , bMono      = False
                 , bInfix     = isInfixIdent (getIdent (thing ln))
                 , bFixity    = Nothing
                 , bDoc       = Nothing
                 , bExport    = Public
                 }
  , exportDecl mbDoc Public
    $ DSignature [ln] sig
  ]

mkPrimTypeDecl ::
  Maybe (Located Text) ->
  Schema PName ->
  Located Kind ->
  ParseM [TopDecl PName]
mkPrimTypeDecl mbDoc (Forall as qs st ~(Just schema_rng)) finK =
  case splitT st of
    Just (n,xs) ->
      do vs <- mapM tpK as
         unless (distinct (map fst vs)) $
            errorMessage schema_rng ["Repeated parameters."]
         let kindMap = Map.fromList vs
             lkp v = case Map.lookup (thing v) kindMap of
                       Just (k,tp)  -> pure (k,tp)
                       Nothing ->
                        errorMessage
                            (srcRange v)
                            ["Undefined parameter: " ++ show (pp (thing v))]
         (as',ins) <- unzip <$> mapM lkp xs
         unless (length vs == length xs) $
           errorMessage schema_rng ["All parameters should appear in the type."]

         let ki = finK { thing = foldr KFun (thing finK) ins }

         pure [ DPrimType TopLevel
                  { tlExport = Public
                  , tlDoc    = mbDoc
                  , tlValue  = PrimType { primTName   = n
                                        , primTKind   = ki
                                        , primTCts    = (as',qs)
                                        , primTFixity = Nothing
                                        }
                 }
              ]

    Nothing -> errorMessage schema_rng ["Invalid primitive signature"]

  where
  splitT ty   = case ty of
                  TLocated t _ -> splitT t
                  TUser n ts -> mkT n ts
                  TInfix t1 n _ t2  -> mkT n [t1,t2]
                  _ -> Nothing

  mkT n ts   = do ts1 <- mapM isVar ts
                  guard (distinct (map thing ts1))
                  pure (n,ts1)

  isVar ty   = case ty of
                 TLocated t _   -> isVar t
                 TUser n []     -> Just n
                 _              -> Nothing

  -- inefficient, but the lists should be small
  distinct xs = case xs of
                  [] -> True
                  x : ys -> not (x `elem` ys) && distinct ys

  tpK tp = case tpKind tp of
             Just k  -> pure (tpName tp, (tp,k))
             Nothing ->
              case tpRange tp of
                Just r -> errorMessage r ["Parameters need a kind annotation"]
                Nothing -> panic "mkPrimTypeDecl"
                              [ "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 ltxt = ltxt { thing = docStr }
  where

  docStr = T.unlines
         $ handlePrefixes
         $ T.lines
         $ T.dropWhileEnd commentChar
         $ thing ltxt

  commentChar :: Char -> Bool
  commentChar x = x `elem` ("/*" :: String) || isSpace x

  -- Prefix dropping with a special case for the first line and common
  -- prefix dropping for the following lines. The first line and following
  -- lines are treated independently
  handlePrefixes :: [Text] -> [Text]
  handlePrefixes [] = []
  handlePrefixes (l:ls)
    | T.all commentChar l = ls'
    | otherwise           = T.dropWhile commentChar l : ls'
    where ls' = dropPrefix ls

  dropPrefix :: [Text] -> [Text]
  dropPrefix ts =
    case startDropPrefixChar ts of
      Nothing -> ts -- done dropping
      Just ts' -> dropPrefix ts' -- keep dropping

  -- At the beginning of a prefix stripping operation we check the
  -- first character of the first line. If that first character is
  -- droppable we use it as the prefix to check for, otherwise we
  -- continue searching for whitespace. Return Nothing if there
  -- was no prefix to drop.
  startDropPrefixChar :: [Text] -> Maybe [Text]
  startDropPrefixChar [] = Nothing
  startDropPrefixChar (l:ls) =
    case T.uncons l of
      Nothing -> (l:) <$> searchWhitePrefixChar ls
      Just (c, l')
        | c == '*' || isSpace c -> (l':) <$> checkPrefixChar c ls
        | otherwise -> Nothing

  -- So far we've only seen empty lines, so we accept empty
  -- lines and lines starting with whitespace.
  searchWhitePrefixChar :: [Text] -> Maybe [Text]
  searchWhitePrefixChar [] = Just []
  searchWhitePrefixChar (l:ls) =
    case T.uncons l of
      Nothing -> (l:) <$> searchWhitePrefixChar ls
      Just (c, l')
        | isSpace c -> (l':) <$> checkPrefixChar c ls
        | otherwise -> Nothing

  -- So far we've seen a non-empty line and we know what character
  -- we're looking for. If that character is whitespace then we also
  -- will accept empty lines as matching the prefix
  checkPrefixChar :: Char -> [Text] -> Maybe [Text]
  checkPrefixChar _ [] = Just []
  checkPrefixChar p (l:ls) =
    case T.uncons l of
      Nothing
        | isSpace p -> (l:) <$> checkPrefixChar p ls
      Just (c,l')
        | c == p -> (l':) <$> checkPrefixChar p ls
      _ -> Nothing

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

mkPropGuards :: Type PName -> ParseM [Located (Prop PName)]
mkPropGuards ty =
  do lp <- mkProp ty
     pure [ lp { thing = p } | p <- thing lp ]

mkProp :: Type PName -> ParseM (Located [Prop PName])
mkProp ty =
  case ty of
    TLocated t r -> Located r `fmap` props r t
    _            -> panic "Parser" [ "Invalid type given to mkProp"
                                   , "expected a location"
                                   , show ty ]

  where

  props r t =
    case t of
      TInfix{}       -> return [CType t]
      TUser{}        -> return [CType t]
      TTuple ts      -> concat `fmap` mapM (props r) ts
      TParens t' mb  -> case mb of
                          Nothing -> props r t'
                          Just _  -> err

      TLocated t' r' -> props r' t'

      TFun{}    -> err
      TSeq{}    -> err
      TBit{}    -> err
      TNum{}    -> err
      TChar{}   -> err
      TWild     -> err
      TRecord{} -> err
      TTyApp{}  -> err

    where
    err = errorMessage r ["Invalid constraint"]

-- | Make an ordinary module
mkModule :: Located ModName -> [TopDecl PName] -> Module PName
mkModule nm ds = Module { mName = nm
                        , mDef = NormalModule ds
                        , mInScope = mempty
                        , mDocTop = Nothing
                        }

-- | Make a nested module, i.e. when you have a module inside a module.
mkNested :: Module PName -> ParseM (NestedModule PName)
mkNested m =
  case modNameChunks (thing nm) of
    [c] -> pure (NestedModule m { mName = nm { thing = mkUnqual (packIdent c)}})
    _   -> errorMessage r
                ["Nested modules names should be a simple identifier."]
  where
  nm = mName m
  r = srcRange nm

mkSigDecl :: Maybe (Located Text) -> (Located PName,Signature PName) -> TopDecl PName
mkSigDecl doc (nm,sig) =
  DModule
  TopLevel { tlExport = Public
           , tlDoc    = doc
           , tlValue  = NestedModule
                        Module { mName    = nm
                               , mDef     = InterfaceModule sig
                               , mInScope = mempty
                               , mDocTop  = Nothing
                               }
           }

mkInterfaceConstraint ::
  Maybe (Located Text) -> Type PName -> ParseM [TopDecl PName]
mkInterfaceConstraint mbDoc ty =
  do ps <- mkProp ty
     pure [DInterfaceConstraint mbDoc ps]

mkParDecls :: [ParamDecl PName] -> TopDecl PName
mkParDecls ds = DParamDecl loc (mkInterface' [] ds)
  where loc = rCombs (mapMaybe getLoc ds)

onlySimpleImports :: [Located (ImportG (ImpName PName))] -> ParseM ()
onlySimpleImports = mapM_ check
  where
  check i =
    case iInst (thing i) of
      Nothing -> pure ()
      Just _  ->
        errorMessage (srcRange i)
          [ "Functor instantiations are not supported in this context."
          , "The imported entity needs to be just the name of a module."
          , "A workaround would be to do the instantion in the outer context."
          ]

mkInterface' :: [Located (ImportG (ImpName PName))] ->
             [ParamDecl PName] -> Signature PName
mkInterface' is =
  foldl' add
    Signature { sigImports     = is
              , sigTypeParams  = []
              , sigDecls       = []
              , sigConstraints = []
              , sigFunParams   = []
              }
  where
  add s d =
    case d of
      DParameterType pt       -> s { sigTypeParams  = pt  : sigTypeParams s  }
      DParameterConstraint ps -> s { sigConstraints = pcProps ps ++ sigConstraints s }
      DParameterDecl pd       -> s { sigDecls       = pd  : sigDecls s       }
      DParameterFun pf        -> s { sigFunParams   = pf  : sigFunParams s   }



mkInterface :: [Located (ImportG (ImpName PName))] ->
             [ParamDecl PName] -> ParseM (Signature PName)
mkInterface is ps =
  do onlySimpleImports is
     pure (mkInterface' is ps)

mkIfacePropSyn :: Maybe Text -> Decl PName -> ParamDecl PName
mkIfacePropSyn mbDoc d =
  case d of
    DLocated d1 _ -> mkIfacePropSyn mbDoc d1
    DType ts    -> DParameterDecl (SigTySyn ts mbDoc)
    DProp ps    -> DParameterDecl (SigPropSyn ps mbDoc)
    _ -> panic "mkIfacePropSyn" [ "Unexpected declaration", show (pp d) ]


-- | Make an unnamed module---gets the name @Main@.
mkAnonymousModule :: [TopDecl PName] -> ParseM [Module PName]
mkAnonymousModule ds =
  do for_ ds \case
       DParamDecl l _            -> mainParamError l
       DModParam p               -> mainParamError (srcRange (mpSignature p))
       DInterfaceConstraint _ ps -> mainParamError (srcRange ps)
       _                         -> pure ()
     src <- cfgSource <$> askConfig
     mkTopMods Nothing $
        mkModule Located
          { srcRange = emptyRange
          , thing    = mainModName src
          }
                          ds
  where
  mainParamError l = errorMessage l
    ["Unnamed module cannot be parameterized"]

-- | Make a module which defines a functor instance.
mkModuleInstanceAnon :: Located ModName ->
                      Located (ImpName PName) ->
                      [TopDecl PName] ->
                      Module PName
mkModuleInstanceAnon nm fun ds =
  Module { mName    = nm
         , mDef     = FunctorInstance fun (DefaultInstAnonArg ds) mempty
         , mInScope = mempty
         , mDocTop  = Nothing
         }

mkModuleInstance ::
  Located ModName ->
  Located (ImpName PName) ->
  ModuleInstanceArgs PName ->
  Module PName
mkModuleInstance m f as =
  Module { mName    = m
         , mDef     = FunctorInstance f as emptyModuleInstance
         , mInScope = mempty
         , mDocTop  = Nothing
         }


ufToNamed :: UpdField PName -> ParseM (Named (Expr PName))
ufToNamed (UpdField h ls e) =
  case (h,ls) of
    (UpdSet, [l]) | RecordSel i Nothing <- thing l ->
      pure Named { name = l { thing = i }, value = e }
    _ -> errorMessage (srcRange lab)
            ["Invalid record field.  Perhaps you meant to update a record?"]
  where
    -- The list of field updates in an UpdField should always be non-empty.
    lab = case ls of
            lab':_ -> lab'
            [] -> panic "ufToNamed" ["UpdField with empty labels"]

-- | The returned list of 'Selector's will be non-empty.
exprToFieldPath :: Expr PName -> ParseM [Located Selector]
exprToFieldPath e0 = reverse <$> go noLoc e0
  where
  noLoc = panic "selExprToSels" ["Missing location?"]
  go loc expr =
    case expr of
      ELocated e1 r -> go r e1
      ESel e2 s ->
        do ls <- go loc e2
           let l =
                 case ls of
                   l':_ -> l'
                   [] -> panic "exprToFieldPath" ["empty list of selectors"]
           let rng = loc { from = to (srcRange l) }
           pure (Located { thing = s, srcRange = rng } : ls)
      EVar (UnQual l) ->
        pure [ Located { thing = RecordSel l Nothing, srcRange = loc } ]

      ELit (ECNum n (DecLit {})) ->
        pure [ Located { thing = TupleSel (fromInteger n) Nothing
                       , srcRange = loc } ]

      ELit (ECFrac _ (DecFrac txt))
        | (as,bs') <- T.break (== '.') txt
        , Just a <- readMaybe (T.unpack as)
        , Just (_,bs) <- T.uncons bs'
        , Just b <- readMaybe (T.unpack bs)
        , let fromP = from loc
        , let midP  = advanceColBy (T.length as + 1) fromP ->
          -- these are backward because we reverse above
          pure [ Located { thing    = TupleSel b Nothing
                         , srcRange = loc { from = midP }
                         }
               , Located { thing    = TupleSel a Nothing
                         , srcRange = loc { to = midP }
                         }
               ]

      _ -> errorMessage loc ["Invalid label in record update."]


mkSelector :: Token -> Selector
mkSelector tok =
  case tokenType tok of
    Selector (TupleSelectorTok n) -> TupleSel n Nothing
    Selector (RecordSelectorTok t) -> RecordSel (mkIdent t) Nothing
    _ -> panic "mkSelector" [ "Unexpected selector token", show tok ]

mkBacktickImport ::
  Range ->
  Located (ImpName PName) ->
  Maybe (Located ModName) ->
  Maybe (Located ImportSpec) ->
  Maybe (Located Text) ->
  ParseM (Located (ImportG (ImpName PName)))
mkBacktickImport loc impName mbAs mbImportSpec =
  mkImport loc impName (Just inst) mbAs mbImportSpec Nothing
  where
  inst = DefaultInstArg (fmap (const AddParams) impName)


mkImport ::
  Range ->
  Located (ImpName PName) ->
  Maybe (ModuleInstanceArgs PName) ->
  Maybe (Located ModName) ->
  Maybe (Located ImportSpec) ->
  Maybe (Located [Decl PName]) ->
  Maybe (Located Text) ->
  ParseM (Located (ImportG (ImpName PName)))

mkImport loc impName optInst mbAs mbImportSpec optImportWhere doc =
  do i <- getInst
     let end = fromMaybe (srcRange impName)
             $ msum [ srcRange <$> optImportWhere
                    , srcRange <$> mbImportSpec
                    , srcRange <$> mbAs
                    ]

     pure Located { srcRange = rComb loc end
                  , thing    = Import
                                 { iModule    = impName
                                 , iAs        = thing <$> mbAs
                                 , iSpec      = thing <$> mbImportSpec
                                 , iInst      = i
                                 , iDoc       = doc
                                 }
                  }
  where
  getInst =
    case (optInst,optImportWhere) of
      (Just _, Just _) ->
         errorMessage loc [ "Invalid instantiating import."
                          , "Import should have at most one of:"
                          , "  * { } instantiation, or"
                          , "  * where instantiation"
                          ]
      (Just a, Nothing)  -> pure (Just a)
      (Nothing, Just a)  ->
        pure (Just (DefaultInstAnonArg (map instTop (thing a))))
         where
         instTop d = Decl TopLevel
                            { tlExport = Public
                            , tlDoc    = Nothing
                            , tlValue  = d
                            }
      (Nothing, Nothing) -> pure Nothing





mkTopMods :: Maybe (Located Text) -> Module PName -> ParseM [Module PName]
mkTopMods doc m =
 do (m', ms) <- desugarMod m { mDocTop = doc }
    pure (ms ++ [m'])

mkTopSig :: Maybe (Located Text) -> Located ModName -> Signature PName -> [Module PName]
mkTopSig doc nm sig =
  [ Module { mName    = nm
           , mDef     = InterfaceModule sig
           , mInScope = mempty
           , mDocTop  = doc
           }
  ]


class MkAnon t where
  mkAnon    :: AnonThing -> t -> t
  toImpName :: t -> ImpName PName

data AnonThing = AnonArg Int Int
                -- ^ The ints are line, column used for disambiguation
               | AnonIfaceMod

instance MkAnon ModName where
  mkAnon what   = case what of
                    AnonArg l c  -> modNameArg l c
                    AnonIfaceMod -> modNameIfaceMod
  toImpName     = ImpTop

-- | Make anonymous names, i.e. a thing without a user visible name.
--   Anonymous names are used when we desugar some things related to the module system  
--   (e.g. parameter blocks become interface modules).
instance MkAnon PName where
  mkAnon what   = mkUnqualSystem
                . case what of
                    AnonArg l c  -> const (identAnonArg l c)
                    AnonIfaceMod -> identAnonIfaceMod
                . getIdent
  toImpName     = ImpNested

-- | Desugar a module returning first the updated original module and a
-- list of any new modules generated by desugaring.
desugarMod :: MkAnon name => ModuleG name PName -> ParseM (ModuleG name PName, [ModuleG name PName])
desugarMod mo =
  case mDef mo of

    FunctorInstance f as _ | DefaultInstAnonArg lds <- as ->
      do (ms,lds') <- desugarTopDs (mName mo) lds
         case ms of
           m : _ | InterfaceModule si <- mDef m
                 , l : _ <- map (srcRange . ptName) (sigTypeParams si) ++
                            map (srcRange . pfName) (sigFunParams si) ++
                            [ srcRange (mName mo) ] ->
              errorMessage l
                [ "Instantiation of a parameterized module may not itself be "
                  ++ "parameterized" ]
           _ -> pure ()
         let i      = mkAnon (AnonArg (line pos) (col pos)) (thing (mName mo))
             pos    = from (srcRange nm)
             nm     = Located { srcRange = srcRange (mName mo), thing = i }
             as'    = DefaultInstArg (ModuleArg . toImpName <$> nm)
         pure ( mo { mDef = FunctorInstance f as' mempty }
              , [ Module
                    { mName = nm
                    , mDef  = NormalModule lds'
                    , mInScope = mempty
                    , mDocTop = Nothing
                    }]
              )

    NormalModule ds ->
      do (newMs, newDs) <- desugarTopDs (mName mo) ds
         pure (mo {mDef = NormalModule newDs }, newMs)

    _ -> pure (mo, [])


desugarTopDs ::
  MkAnon name =>
  Located name ->
  [TopDecl PName] ->
  ParseM ([ModuleG name PName], [TopDecl PName])
desugarTopDs ownerName = go emptySig
  where
  isEmpty s =
    null (sigTypeParams s) && null (sigConstraints s) && null (sigFunParams s)

  emptySig = Signature
    { sigImports      = []
    , sigTypeParams   = []
    , sigDecls        = []
    , sigConstraints  = []
    , sigFunParams    = []
    }

  jnSig s1 s2 = Signature { sigImports      = j sigImports
                          , sigTypeParams   = j sigTypeParams
                          , sigDecls        = j sigDecls
                          , sigConstraints  = j sigConstraints
                          , sigFunParams    = j sigFunParams
                          }

      where
      j f = f s1 ++ f s2

  addI i s = s { sigImports = i : sigImports s }

  go sig ds =
    case ds of

      []
        | isEmpty sig -> pure ([],[])
        | otherwise ->
          do let nm = mkAnon AnonIfaceMod <$> ownerName
             pure ( [ Module { mName = nm
                             , mDef = InterfaceModule sig
                             , mInScope = mempty
                             , mDocTop = Nothing
                             }
                     ]
                  , [ DModParam
                      ModParam
                        { mpSignature = toImpName <$> nm
                        , mpAs        = Nothing
                        , mpName      = mkModParamName (toImpName <$> nm)
                                                                        Nothing
                        , mpDoc       = Nothing
                        , mpRenaming  = mempty
                        }
                      ]
                  )

      d : more ->
        let cont emit sig' =
              do (ms,ds') <- go sig' more
                 pure (ms, emit ++ ds')
        in
        case d of

          DImport i
            | ImpTop _ <- thing (iModule (thing i))
            , Nothing  <- iInst (thing i) ->
            cont [d] (addI i sig)

          DImport i
            | Just inst <- iInst (thing i) ->
            do newDs <- desugarInstImport i inst
               cont newDs sig

          DParamDecl _ ds' -> cont [] (jnSig ds' sig)

          DModule tl | NestedModule mo <- tlValue tl ->
            do (mo', ms) <- desugarMod mo
               cont ([ DModule TopLevel
                          { tlExport = tlExport tl
                          , tlValue = NestedModule m
                          , tlDoc = Nothing -- generated modules have no docstrings
                          }
                      | m <- ms] ++ [DModule tl { tlValue = NestedModule mo' }])
                    sig

          _ -> cont [d] sig

desugarInstImport ::
  Located (ImportG (ImpName PName)) {- ^ The import -} ->
  ModuleInstanceArgs PName          {- ^ The insantiation -} ->
  ParseM [TopDecl PName]
desugarInstImport i inst =
  do (m, ms) <- desugarMod
           Module { mName    = iname
                  , mDef     = FunctorInstance
                                 origMod inst emptyModuleInstance
                  , mInScope = mempty
                  , mDocTop  = Nothing
                  }
     pure (DImport (newImp <$> i) : map modTop (ms ++ [m]))

  where
  origMod = iModule (thing i)

  iname = Located {
    thing = mkUnqualSystem
        $ let pos = from (srcRange i)
          in identAnonInstImport (line pos) (col pos),
    srcRange = srcRange origMod
  }
      

  newImp d = d { iModule = ImpNested <$> iname
               , iInst   = Nothing
               }

  modTop m = DModule TopLevel
                       { tlExport = Private
                       , tlDoc    = Nothing
                       , tlValue  = NestedModule m
                       }