live-sequencer-0.0.6.1: src/Exception.hs

module Exception where

import qualified Term
import qualified SourceText as Source
import qualified ModuleBase as Module
import Term ( Term )
import SourceText ( Range(Range), ModuleRange(ModuleRange) )

import qualified Control.Monad.Exception.Synchronous as ME

import qualified Text.ParserCombinators.Parsec.Error as PErr
import qualified Text.ParserCombinators.Parsec.Pos as Pos

import qualified Data.List as List

import Data.Maybe ( Maybe (Just, Nothing), maybe )
import Data.Bool.HT ( if' )

import Prelude (
            String, Bounded, Int, Show, show, ($), (.), (++),
            maxBound, minBound,
            (<), fromInteger, fromIntegral,
            head, lines,
            return,
            )


data Message = Message Type String
--    deriving (Show)

data Type = Parse Module.Source Range | Term ModuleRange | InOut Module.Source
    deriving (Show)


type Monad = ME.Exceptional Message
type MonadT = ME.ExceptionalT Message

messageParse :: Module.Source -> Range -> String -> Message
messageParse name = Message . Parse name

messageParseModuleRange :: ModuleRange -> String -> Exception.Message
messageParseModuleRange (ModuleRange modu _ rng) =
    messageParse (Module.Editor modu) rng

messageTerm :: ModuleRange -> String -> Message
messageTerm = Message . Term

messageInOut :: Module.Source -> String -> Message
messageInOut = Message . InOut

messageInOutEditor :: Module.Name -> String -> Exception.Message
messageInOutEditor = messageInOut . Module.Editor


lineFromMessage :: Message -> [String]
lineFromMessage (Message typ descr) =
    case stringsFromType typ of
        (typeStr, name, mpos) ->
            name :
            maybe ["",""] (\(line,column) -> [line,column]) mpos ++
            typeStr :
            head (lines descr) :
            []

statusFromMessage :: Message -> String
statusFromMessage (Message typ descr) =
    case stringsFromType typ of
        (typeStr, name, mpos) ->
            typeStr ++ " - " ++
            formatPos name mpos ++ " - " ++
            flattenMultiline descr

multilineFromMessage :: Message -> String
multilineFromMessage (Message typ descr) =
    case stringsFromType typ of
        (typeStr, name, mpos) ->
            typeStr ++ " - " ++
            formatPos name mpos ++ "\n" ++
            descr

formatPos :: String -> Maybe (String, String) -> String
formatPos name mpos =
    name ++ maybe "" (\(line,column) -> ':':line++':':column) mpos

stringsFromType :: Type -> (String, String, Maybe (String, String))
stringsFromType typ =
    case typ of
        Parse name rng ->
            ("parse error", Module.formatSource name,
             Just $ stringFromRange rng)
        Term (ModuleRange name _ rng) ->
            ("term error", Module.deconsName name, Just $ stringFromRange rng)
        InOut name ->
            ("in/out error", Module.formatSource name, Nothing)

stringFromRange :: Range -> (String, String)
stringFromRange (Range (Source.Position line column) _) =
    (show line, show column)

flattenMultiline :: String -> String
flattenMultiline = List.intercalate "; " . lines


messageFromParserError :: Module.Source -> PErr.ParseError -> Message
messageFromParserError source err =
    let p = PErr.errorPos err
    in  messageParse source
            (Source.consRange p (Pos.updatePosChar p ' '))
            (removeLeadingNewline $
             PErr.showErrorMessages
                 "or" "unknown parse error"
                 "expecting" "unexpected" "end of input" $
             PErr.errorMessages err)

removeLeadingNewline :: String -> String
removeLeadingNewline ('\n':str) = str
removeLeadingNewline str = str



checkRange ::
    (Bounded a) =>
    (range -> String -> Message) ->
    String -> (Int -> a) -> (a -> Int) ->
    a -> a ->
    Term range ->
    Exception.Monad a
checkRange makeMsg typ fromInt toInt minb maxb (Term.Number rng x) =
    if' (x < fromIntegral (toInt minb))
        (ME.throw $ makeMsg rng $
            typ ++ " argument " ++ show x ++
                " is less than minimum value " ++ show (toInt minb)) $
    if' (fromIntegral (toInt maxb) < x)
        (ME.throw $ makeMsg rng $
            typ ++ " argument " ++ show x ++
                " is greater than maximum value " ++ show (toInt maxb)) $
    return $ fromInt $ fromInteger x
checkRange makeMsg typ _ _ _ _ t =
    ME.throw $
    makeMsg (Term.termRange t) (typ ++ " argument is not a number")

checkRangeAuto ::
    (Bounded a) =>
    (range -> String -> Message) ->
    String -> (Int -> a) -> (a -> Int) ->
    Term range ->
    Exception.Monad a
checkRangeAuto makeMsg typ fromInt0 toInt0 =
    checkRange makeMsg typ fromInt0 toInt0 minBound maxBound