{- |
    Module      :  $Header$
    Description :  Lexer combinators
    Copyright   :  (c) 1999 - 2004, Wolfgang Lux
                       2012 - 2013, Björn Peemöller
                       2016       , Jan Tikovsky
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module provides the basic types and combinators to implement the
    lexers. The combinators use continuation passing code in a monadic style.

    The first argument of the continuation function is the current span,
    and the second is the string to be parsed. The third argument is a flag
    which signals the lexer that it is lexing the beginning of a line and
    therefore has to check for layout tokens. The fourth argument is a stack
    of indentations that is used to handle nested layout groups.
-}
module Curry.Base.LexComb
  ( -- * Types
    Symbol (..), Indent, Context, P, CYM, SuccessP, FailP, Lexer

    -- * Monadic functions
  , parse, applyLexer, returnP, thenP, thenP_, failP, warnP
  , liftP, closeP0, closeP1

    -- * Combinators for layout handling
  , pushContext, popContext

    -- * Conversion of numbers
  , convertSignedIntegral, convertSignedFloating
  , convertIntegral, convertFloating
  ) where

import Data.Char        (digitToInt)

import Curry.Base.Monad (CYM, failMessageAt, warnMessageAt)
import Curry.Base.Span  ( Distance, Span (..), startCol, fstSpan
                        , setDistance)


infixl 1 `thenP`, `thenP_`

-- |Type class for symbols
class (Ord s, Show s) => Symbol s where
  -- |Does the 'Symbol' represent the end of the input?
  isEOF :: s -> Bool
  -- |Compute the distance of a 'Symbol'
  dist :: Int -> s -> Distance

-- |Type for indentations, necessary for the layout rule
type Indent = Int

-- |Type of context for representing layout grouping
type Context = [Indent]

-- |Basic lexer function
type P a = Span     -- ^ Current source code span
        -> String   -- ^ 'String' to be parsed
        -> Bool     -- ^ Flag whether the beginning of a line should be
                    --   parsed, which requires layout checking
        -> Context  -- ^ context as a stack of 'Indent's
        -> CYM a

-- |Apply a lexer on a 'String' to lex the content. The second parameter
-- requires a 'FilePath' to use in the 'Span'
parse :: P a -> FilePath -> String -> CYM a
parse :: P a -> FilePath -> FilePath -> CYM a
parse p :: P a
p fn :: FilePath
fn s :: FilePath
s = P a
p (FilePath -> Span
fstSpan FilePath
fn) FilePath
s Bool
True []

-- ---------------------------------------------------------------------------
-- CPS lexer
-- ---------------------------------------------------------------------------

-- |success continuation
type SuccessP s a = Span -> s -> P a

-- |failure continuation
type FailP a      = Span -> String -> P a

-- |A CPS lexer
type Lexer s a    = SuccessP s a -> FailP a -> P a

-- |Apply a lexer
applyLexer :: Symbol s => Lexer s [(Span, s)] -> P [(Span, s)]
applyLexer :: Lexer s [(Span, s)] -> P [(Span, s)]
applyLexer lexer :: Lexer s [(Span, s)]
lexer = Lexer s [(Span, s)]
lexer SuccessP s [(Span, s)]
successP Span -> FilePath -> P [(Span, s)]
forall a. Span -> FilePath -> P a
failP
  where successP :: SuccessP s [(Span, s)]
successP sp :: Span
sp t :: s
t | s -> Bool
forall s. Symbol s => s -> Bool
isEOF s
t   = [(Span, s)] -> P [(Span, s)]
forall a. a -> P a
returnP [(Span
sp', s
t)]
                      | Bool
otherwise = ((Span
sp', s
t) (Span, s) -> [(Span, s)] -> [(Span, s)]
forall a. a -> [a] -> [a]
:) ([(Span, s)] -> [(Span, s)]) -> P [(Span, s)] -> P [(Span, s)]
forall a b. (a -> b) -> P a -> P b
`liftP` Lexer s [(Span, s)]
lexer SuccessP s [(Span, s)]
successP Span -> FilePath -> P [(Span, s)]
forall a. Span -> FilePath -> P a
failP
          where sp' :: Span
sp' = Span -> Distance -> Span
setDistance Span
sp (Int -> s -> Distance
forall s. Symbol s => Int -> s -> Distance
dist (Span -> Int
startCol Span
sp) s
t)

-- ---------------------------------------------------------------------------
-- Monadic functions for the lexer.
-- ---------------------------------------------------------------------------

-- |Lift a value into the lexer type
returnP :: a -> P a
returnP :: a -> P a
returnP x :: a
x _ _ _ _ = a -> WriterT [Message] (ExceptT [Message] Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- |Apply the first lexer and then apply the second one, based on the result
-- of the first lexer.
thenP :: P a -> (a -> P b) -> P b
thenP :: P a -> (a -> P b) -> P b
thenP lexer :: P a
lexer k :: a -> P b
k sp :: Span
sp s :: FilePath
s bol :: Bool
bol ctxt :: Context
ctxt
  = P a
lexer Span
sp FilePath
s Bool
bol Context
ctxt WriterT [Message] (ExceptT [Message] Identity) a
-> (a -> WriterT [Message] (ExceptT [Message] Identity) b)
-> WriterT [Message] (ExceptT [Message] Identity) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: a
x -> a -> P b
k a
x Span
sp FilePath
s Bool
bol Context
ctxt

-- |Apply the first lexer and then apply the second one, ignoring the first
-- result.
thenP_ :: P a -> P b -> P b
p1 :: P a
p1 thenP_ :: P a -> P b -> P b
`thenP_` p2 :: P b
p2 = P a
p1 P a -> (a -> P b) -> P b
forall a b. P a -> (a -> P b) -> P b
`thenP` P b -> a -> P b
forall a b. a -> b -> a
const P b
p2

-- |Fail to lex on a 'Span', given an error message
failP :: Span -> String -> P a
failP :: Span -> FilePath -> P a
failP sp :: Span
sp msg :: FilePath
msg _ _ _ _ = Span -> FilePath -> CYT Identity a
forall (m :: * -> *) a. Monad m => Span -> FilePath -> CYT m a
failMessageAt Span
sp FilePath
msg

-- |Warn on a 'Span', given a warning message
warnP :: Span -> String -> P a -> P a
warnP :: Span -> FilePath -> P a -> P a
warnP warnSpan :: Span
warnSpan msg :: FilePath
msg lexer :: P a
lexer sp :: Span
sp s :: FilePath
s bol :: Bool
bol ctxt :: Context
ctxt
  = Span -> FilePath -> CYT Identity ()
forall (m :: * -> *). Monad m => Span -> FilePath -> CYT m ()
warnMessageAt Span
warnSpan FilePath
msg CYT Identity ()
-> WriterT [Message] (ExceptT [Message] Identity) a
-> WriterT [Message] (ExceptT [Message] Identity) a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> P a
lexer Span
sp FilePath
s Bool
bol Context
ctxt

-- |Apply a pure function to the lexers result
liftP :: (a -> b) -> P a -> P b
liftP :: (a -> b) -> P a -> P b
liftP f :: a -> b
f p :: P a
p = P a
p P a -> (a -> P b) -> P b
forall a b. P a -> (a -> P b) -> P b
`thenP` b -> P b
forall a. a -> P a
returnP (b -> P b) -> (a -> b) -> a -> P b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

-- |Lift a lexer into the 'P' monad, returning the lexer when evaluated.
closeP0 :: P a -> P (P a)
closeP0 :: P a -> P (P a)
closeP0 lexer :: P a
lexer sp :: Span
sp s :: FilePath
s bol :: Bool
bol ctxt :: Context
ctxt = P a -> WriterT [Message] (ExceptT [Message] Identity) (P a)
forall (m :: * -> *) a. Monad m => a -> m a
return (\_ _ _ _ -> P a
lexer Span
sp FilePath
s Bool
bol Context
ctxt)

-- |Lift a lexer-generating function into the 'P' monad, returning the
--  function when evaluated.
closeP1 :: (a -> P b) -> P (a -> P b)
closeP1 :: (a -> P b) -> P (a -> P b)
closeP1 f :: a -> P b
f sp :: Span
sp s :: FilePath
s bol :: Bool
bol ctxt :: Context
ctxt = (a -> P b)
-> WriterT [Message] (ExceptT [Message] Identity) (a -> P b)
forall (m :: * -> *) a. Monad m => a -> m a
return (\x :: a
x _ _ _ _ -> a -> P b
f a
x Span
sp FilePath
s Bool
bol Context
ctxt)

-- ---------------------------------------------------------------------------
-- Combinators for handling layout.
-- ---------------------------------------------------------------------------

-- |Push an 'Indent' to the context, increasing the levels of indentation
pushContext :: Indent -> P a -> P a
pushContext :: Int -> P a -> P a
pushContext col :: Int
col cont :: P a
cont sp :: Span
sp s :: FilePath
s bol :: Bool
bol ctxt :: Context
ctxt = P a
cont Span
sp FilePath
s Bool
bol (Int
col Int -> Context -> Context
forall a. a -> [a] -> [a]
: Context
ctxt)

-- |Pop an 'Indent' from the context, decreasing the levels of indentation
popContext :: P a -> P a
popContext :: P a -> P a
popContext cont :: P a
cont sp :: Span
sp s :: FilePath
s bol :: Bool
bol (_ : ctxt :: Context
ctxt) = P a
cont Span
sp FilePath
s Bool
bol Context
ctxt
popContext _    sp :: Span
sp _ _   []         = Span -> FilePath -> CYT Identity a
forall (m :: * -> *) a. Monad m => Span -> FilePath -> CYT m a
failMessageAt Span
sp (FilePath -> CYT Identity a) -> FilePath -> CYT Identity a
forall a b. (a -> b) -> a -> b
$
  "Parse error: popping layout from empty context stack. " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
  "Perhaps you have inserted too many '}'?"

-- ---------------------------------------------------------------------------
-- Conversions from 'String's into numbers.
-- ---------------------------------------------------------------------------

-- |Convert a String into a signed intergral using a given base
convertSignedIntegral :: Num a => a -> String -> a
convertSignedIntegral :: a -> FilePath -> a
convertSignedIntegral b :: a
b ('+':s :: FilePath
s) =   a -> FilePath -> a
forall a. Num a => a -> FilePath -> a
convertIntegral a
b FilePath
s
convertSignedIntegral b :: a
b ('-':s :: FilePath
s) = - a -> FilePath -> a
forall a. Num a => a -> FilePath -> a
convertIntegral a
b FilePath
s
convertSignedIntegral b :: a
b s :: FilePath
s       =   a -> FilePath -> a
forall a. Num a => a -> FilePath -> a
convertIntegral a
b FilePath
s

-- |Convert a String into an unsigned intergral using a given base
convertIntegral :: Num a => a -> String -> a
convertIntegral :: a -> FilePath -> a
convertIntegral b :: a
b = (a -> Char -> a) -> a -> FilePath -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl a -> Char -> a
op 0
  where m :: a
m op :: a -> Char -> a
`op` n :: Char
n = a
b a -> a -> a
forall a. Num a => a -> a -> a
* a
m a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
n)

-- |Convert a mantissa, a fraction part and an exponent into a signed
-- floating value
convertSignedFloating :: Fractional a => String -> String -> Int -> a
convertSignedFloating :: FilePath -> FilePath -> Int -> a
convertSignedFloating ('+':m :: FilePath
m) f :: FilePath
f e :: Int
e =   FilePath -> FilePath -> Int -> a
forall a. Fractional a => FilePath -> FilePath -> Int -> a
convertFloating FilePath
m FilePath
f Int
e
convertSignedFloating ('-':m :: FilePath
m) f :: FilePath
f e :: Int
e = - FilePath -> FilePath -> Int -> a
forall a. Fractional a => FilePath -> FilePath -> Int -> a
convertFloating FilePath
m FilePath
f Int
e
convertSignedFloating m :: FilePath
m       f :: FilePath
f e :: Int
e =   FilePath -> FilePath -> Int -> a
forall a. Fractional a => FilePath -> FilePath -> Int -> a
convertFloating FilePath
m FilePath
f Int
e

-- |Convert a mantissa, a fraction part and an exponent into an unsigned
-- floating value
convertFloating :: Fractional a => String -> String -> Int -> a
convertFloating :: FilePath -> FilePath -> Int -> a
convertFloating m :: FilePath
m f :: FilePath
f e :: Int
e
  | Int
e' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0   = a
m'
  | Int
e' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  0   = a
m' a -> a -> a
forall a. Num a => a -> a -> a
* 10 a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e'
  | Bool
otherwise = a
m' a -> a -> a
forall a. Fractional a => a -> a -> a
/ 10 a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ (- Int
e')
  where m' :: a
m' = a -> FilePath -> a
forall a. Num a => a -> FilePath -> a
convertIntegral 10 (FilePath
m FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f)
        e' :: Int
e' = Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
f