{-|
Module      : DigraphQuote
Description : Template Haskell quasi-quoter for digraph table
Copyright   : (c) Eric Mertens, 2017
License     : ISC
Maintainer  : emertens@gmail.com

-}
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

-- Parse entries, empty lines are ignored, -- comments are allowed
-- Entries are a two-character digraph followed by a hexadecimal
-- representation of the replacement character's unicode value.
--
-- Examples
--
-- > "'   14
-- > AB 0123
-- > CD 0FDE -- with a comment
-- >
-- > -- with a comment
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
"" -- skip empty lines
         | 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)

-- Optionally tolerate a comment
isAllowedTerminator :: [String] -> Bool
isAllowedTerminator :: [String] -> Bool
isAllowedTerminator ((Char
'-':Char
'-':String
_):[String]
_) = Bool
True
isAllowedTerminator []              = Bool
True
isAllowedTerminator [String]
_               = Bool
False