module DigraphQuote (digraphTable) where
import Data.Char
import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Numeric (readHex)
digraphTable :: QuasiQuoter
digraphTable :: QuasiQuoter
digraphTable = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
digraphTableExp
, quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Digraph table must be an expression")
, quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Digraph table must be an expression")
, quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Digraph table must be an expression")
}
digraphTableExp :: String -> ExpQ
digraphTableExp :: String -> Q Exp
digraphTableExp = String -> Q Exp
stringE (String -> Q Exp) -> ([String] -> String) -> [String] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> Q Exp) -> (String -> Q [String]) -> String -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (String -> Q String) -> [String] -> Q [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Q String
parseEntry ([String] -> Q [String])
-> (String -> [String]) -> String -> Q [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
parseEntry :: String -> Q String
parseEntry :: String -> Q String
parseEntry String
line =
case String -> [String]
words String
line of
[Char
x,Char
y] : (Char
'U':Char
'+':String
hex) : [String]
rest
| [(Int
n,String
"")] <- ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex String
hex
, [String] -> Bool
isAllowedTerminator [String]
rest -> String -> Q String
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
x,Char
y,Int -> Char
chr Int
n]
[String]
rest | [String] -> Bool
isAllowedTerminator [String]
rest -> String -> Q String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
| Bool
otherwise -> String -> Q String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Bad digraph entry: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
line)
isAllowedTerminator :: [String] -> Bool
isAllowedTerminator :: [String] -> Bool
isAllowedTerminator ((Char
'-':Char
'-':String
_):[String]
_) = Bool
True
isAllowedTerminator [] = Bool
True
isAllowedTerminator [String]
_ = Bool
False