{-# LANGUAGE MagicHash, UnboxedTuples, FlexibleInstances #-} module TokenDef where import UU.Scanner.Token import UU.Scanner.GenToken import UU.Scanner.Position import UU.Parsing.MachineInterface(Symbol(..)) import Data.Char(isPrint,ord) import HsToken import CommonTypes instance Symbol Token where deleteCost :: Token -> Int# deleteCost (Reserved String key Pos _) = case String key of String "DATA" -> Int# 7# String "EXT" -> Int# 7# String "ATTR" -> Int# 7# String "SEM" -> Int# 7# String "USE" -> Int# 7# String "INCLUDE" -> Int# 7# String _ -> Int# 5# deleteCost (ValToken EnumValToken v String _ Pos _) = case EnumValToken v of EnumValToken TkError -> Int# 0# EnumValToken _ -> Int# 5# tokensToStrings :: [HsToken] -> [(Pos,String)] tokensToStrings :: [HsToken] -> [(Pos, String)] tokensToStrings = (HsToken -> (Pos, String)) -> [HsToken] -> [(Pos, String)] forall a b. (a -> b) -> [a] -> [b] map HsToken -> (Pos, String) tokenToString tokenToString :: HsToken -> (Pos, String) tokenToString :: HsToken -> (Pos, String) tokenToString HsToken tk = case HsToken tk of AGLocal Identifier var Pos pos Maybe String _ -> (Pos pos, String "@" String -> String -> String forall a. [a] -> [a] -> [a] ++ Identifier -> String getName Identifier var) AGField Identifier field Identifier attr Pos pos Maybe String _ -> (Pos pos, String "@" String -> String -> String forall a. [a] -> [a] -> [a] ++ Identifier -> String getName Identifier field String -> String -> String forall a. [a] -> [a] -> [a] ++ String "." String -> String -> String forall a. [a] -> [a] -> [a] ++ Identifier -> String getName Identifier attr) HsToken String value Pos pos -> (Pos pos, String value) CharToken String value Pos pos -> (Pos pos, String -> String forall a. Show a => a -> String show String value) StrToken String value Pos pos -> (Pos pos, String -> String forall a. Show a => a -> String show String value) Err String mesg Pos pos -> (Pos pos, String " ***" String -> String -> String forall a. [a] -> [a] -> [a] ++ String mesg String -> String -> String forall a. [a] -> [a] -> [a] ++ String "*** ") showTokens :: [(Pos,String)] -> [String] showTokens :: [(Pos, String)] -> [String] showTokens [] = [] showTokens [(Pos, String)] xs = ([(Pos, String)] -> String) -> [[(Pos, String)]] -> [String] forall a b. (a -> b) -> [a] -> [b] map [(Pos, String)] -> String showLine ([[(Pos, String)]] -> [String]) -> ([(Pos, String)] -> [[(Pos, String)]]) -> [(Pos, String)] -> [String] forall b c a. (b -> c) -> (a -> b) -> a -> c . [[(Pos, String)]] -> [[(Pos, String)]] forall a. [[(Pos, a)]] -> [[(Pos, a)]] shiftLeft ([[(Pos, String)]] -> [[(Pos, String)]]) -> ([(Pos, String)] -> [[(Pos, String)]]) -> [(Pos, String)] -> [[(Pos, String)]] forall b c a. (b -> c) -> (a -> b) -> a -> c . [(Pos, String)] -> [[(Pos, String)]] forall a. [(Pos, a)] -> [[(Pos, a)]] getLines ([(Pos, String)] -> [String]) -> [(Pos, String)] -> [String] forall a b. (a -> b) -> a -> b $ [(Pos, String)] xs getLines :: [(Pos, a)] -> [[(Pos, a)]] getLines :: [(Pos, a)] -> [[(Pos, a)]] getLines [] = [] getLines ((Pos p,a t):[(Pos, a)] xs) = let ([(Pos, a)] txs,[(Pos, a)] rest) = ((Pos, a) -> Bool) -> [(Pos, a)] -> ([(Pos, a)], [(Pos, a)]) forall a. (a -> Bool) -> [a] -> ([a], [a]) span (Pos, a) -> Bool forall p b. Position p => (p, b) -> Bool sameLine [(Pos, a)] xs sameLine :: (p, b) -> Bool sameLine (p q,b _) = Pos -> Line forall p. Position p => p -> Line line Pos p Line -> Line -> Bool forall a. Eq a => a -> a -> Bool == p -> Line forall p. Position p => p -> Line line p q in ((Pos p,a t)(Pos, a) -> [(Pos, a)] -> [(Pos, a)] forall a. a -> [a] -> [a] :[(Pos, a)] txs) [(Pos, a)] -> [[(Pos, a)]] -> [[(Pos, a)]] forall a. a -> [a] -> [a] : [(Pos, a)] -> [[(Pos, a)]] forall a. [(Pos, a)] -> [[(Pos, a)]] getLines [(Pos, a)] rest shiftLeft :: [[(Pos, a)]] -> [[(Pos, a)]] shiftLeft :: [[(Pos, a)]] -> [[(Pos, a)]] shiftLeft [[(Pos, a)]] lns = let sh :: Line sh = let m :: Line m = [Line] -> Line forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a minimum ([Line] -> Line) -> ([[(Pos, a)]] -> [Line]) -> [[(Pos, a)]] -> Line forall b c a. (b -> c) -> (a -> b) -> a -> c . [Line] -> [Line] forall a. Num a => [a] -> [a] checkEmpty ([Line] -> [Line]) -> ([[(Pos, a)]] -> [Line]) -> [[(Pos, a)]] -> [Line] forall b c a. (b -> c) -> (a -> b) -> a -> c . (Line -> Bool) -> [Line] -> [Line] forall a. (a -> Bool) -> [a] -> [a] filter (Line -> Line -> Bool forall a. Ord a => a -> a -> Bool >=Line 1) ([Line] -> [Line]) -> ([[(Pos, a)]] -> [Line]) -> [[(Pos, a)]] -> [Line] forall b c a. (b -> c) -> (a -> b) -> a -> c . ([(Pos, a)] -> Line) -> [[(Pos, a)]] -> [Line] forall a b. (a -> b) -> [a] -> [b] map (Pos -> Line forall p. Position p => p -> Line column(Pos -> Line) -> ([(Pos, a)] -> Pos) -> [(Pos, a)] -> Line forall b c a. (b -> c) -> (a -> b) -> a -> c .(Pos, a) -> Pos forall a b. (a, b) -> a fst((Pos, a) -> Pos) -> ([(Pos, a)] -> (Pos, a)) -> [(Pos, a)] -> Pos forall b c a. (b -> c) -> (a -> b) -> a -> c .[(Pos, a)] -> (Pos, a) forall a. [a] -> a head) ([[(Pos, a)]] -> Line) -> [[(Pos, a)]] -> Line forall a b. (a -> b) -> a -> b $ [[(Pos, a)]] lns checkEmpty :: [a] -> [a] checkEmpty [] = [a 1] checkEmpty [a] x = [a] x in if Line m Line -> Line -> Bool forall a. Ord a => a -> a -> Bool >= Line 1 then Line mLine -> Line -> Line forall a. Num a => a -> a -> a -Line 1 else Line 0 shift :: (Pos, b) -> (Pos, b) shift (Pos p,b t) = (if Pos -> Line forall p. Position p => p -> Line column Pos p Line -> Line -> Bool forall a. Ord a => a -> a -> Bool >= Line 1 then case Pos p of (Pos Line l Line c String f) -> Line -> Line -> String -> Pos Pos Line l (Line c Line -> Line -> Line forall a. Num a => a -> a -> a - Line sh) String f else Pos p, b t) in ([(Pos, a)] -> [(Pos, a)]) -> [[(Pos, a)]] -> [[(Pos, a)]] forall a b. (a -> b) -> [a] -> [b] map (((Pos, a) -> (Pos, a)) -> [(Pos, a)] -> [(Pos, a)] forall a b. (a -> b) -> [a] -> [b] map (Pos, a) -> (Pos, a) forall b. (Pos, b) -> (Pos, b) shift) [[(Pos, a)]] lns showLine :: [(Pos, [Char])] -> [Char] showLine :: [(Pos, String)] -> String showLine [(Pos, String)] ts = let f :: (a, String) -> (Line -> String) -> Line -> String f (a p,String t) Line -> String r = let ct :: Line ct = a -> Line forall p. Position p => p -> Line column a p in \Line c -> Line -> String spaces (Line ctLine -> Line -> Line forall a. Num a => a -> a -> a -Line c) String -> String -> String forall a. [a] -> [a] -> [a] ++ String t String -> String -> String forall a. [a] -> [a] -> [a] ++ Line -> String r (String -> Line forall (t :: * -> *) a. Foldable t => t a -> Line length String tLine -> Line -> Line forall a. Num a => a -> a -> a +Line ct) spaces :: Line -> String spaces Line x | Line x Line -> Line -> Bool forall a. Ord a => a -> a -> Bool < Line 0 = String "" | Bool otherwise = Line -> Char -> String forall a. Line -> a -> [a] replicate Line x Char ' ' in ((Pos, String) -> (Line -> String) -> Line -> String) -> (Line -> String) -> [(Pos, String)] -> Line -> String forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (Pos, String) -> (Line -> String) -> Line -> String forall a. Position a => (a, String) -> (Line -> String) -> Line -> String f (String -> Line -> String forall a b. a -> b -> a const String "") [(Pos, String)] ts Line 1 showStrShort :: String -> String showStrShort :: String -> String showStrShort String xs = String "\"" String -> String -> String forall a. [a] -> [a] -> [a] ++ (Char -> String) -> String -> String forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Char -> String f String xs String -> String -> String forall a. [a] -> [a] -> [a] ++ String "\"" where f :: Char -> String f Char '"' = String "\\\"" f Char x = Char -> String showCharShort' Char x showCharShort :: Char -> String showCharShort :: Char -> String showCharShort Char '\'' = String "'" String -> String -> String forall a. [a] -> [a] -> [a] ++ String "\\'" String -> String -> String forall a. [a] -> [a] -> [a] ++ String "'" showCharShort Char c = String "'" String -> String -> String forall a. [a] -> [a] -> [a] ++ Char -> String showCharShort' Char c String -> String -> String forall a. [a] -> [a] -> [a] ++ String "'" showCharShort' :: Char -> String showCharShort' :: Char -> String showCharShort' Char '\a' = String "\\a" showCharShort' Char '\b' = String "\\b" showCharShort' Char '\t' = String "\\t" showCharShort' Char '\n' = String "\\n" showCharShort' Char '\r' = String "\\r" showCharShort' Char '\f' = String "\\f" showCharShort' Char '\v' = String "\\v" showCharShort' Char '\\' = String "\\\\" showCharShort' Char x | Char -> Bool isPrint Char x = [Char x] | Bool otherwise = Char '\\' Char -> String -> String forall a. a -> [a] -> [a] : Line -> String forall a. Show a => a -> String show (Char -> Line ord Char x)