{-|
  Copyright  :  (C) 2020, QBayLogic B.V.
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com
-}
{-# LANGUAGE OverloadedStrings #-}

module Clash.Netlist.Id.Common where

import           Control.Arrow (first)
import           Control.Applicative ((<|>))
import           Control.Applicative.Extra (orEmpty)
import           Data.Maybe (fromMaybe)
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Char as Char
import           TextShow (showt)

parseWhiteSpace :: Text -> Maybe Text
parseWhiteSpace :: Text -> Maybe Text
parseWhiteSpace = (Char -> Bool) -> Text -> Maybe Text
parseSingle Char -> Bool
isWhiteSpace

isWhiteSpace :: Char -> Bool
isWhiteSpace :: Char -> Bool
isWhiteSpace Char
c = Char
c Char -> [Char] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Char
' ', Char
'\n', Char
'\t']

parsePrintable :: Text -> Maybe Text
parsePrintable :: Text -> Maybe Text
parsePrintable = (Char -> Bool) -> Text -> Maybe Text
parseSingle (\Char
c -> Char -> Bool
Char.isPrint Char
c Bool -> Bool -> Bool
&& Char -> Bool
Char.isAscii Char
c)

parseSingle :: (Char -> Bool) -> Text -> Maybe Text
parseSingle :: (Char -> Bool) -> Text -> Maybe Text
parseSingle Char -> Bool
predicate Text
s = do
  (Char
l, Text
ls) <- Text -> Maybe (Char, Text)
Text.uncons Text
s
  Bool -> Text -> Maybe Text
forall (f :: Type -> Type) a. Alternative f => Bool -> a -> f a
orEmpty (Char -> Bool
predicate Char
l) Text
ls

parseMaybeSingle :: (Char -> Bool) -> Text -> Maybe Text
parseMaybeSingle :: (Char -> Bool) -> Text -> Maybe Text
parseMaybeSingle Char -> Bool
predicate Text
s = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
s ((Char -> Bool) -> Text -> Maybe Text
parseSingle Char -> Bool
predicate Text
s))

parseLetter :: Text -> Maybe Text
parseLetter :: Text -> Maybe Text
parseLetter = (Char -> Bool) -> Text -> Maybe Text
parseSingle (\Char
c -> Char -> Bool
Char.isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
Char.isLetter Char
c)

parseDigit :: Text -> Maybe Text
parseDigit :: Text -> Maybe Text
parseDigit = (Char -> Bool) -> Text -> Maybe Text
parseSingle Char -> Bool
Char.isDigit

parseLetterOrDigit :: Text -> Maybe Text
parseLetterOrDigit :: Text -> Maybe Text
parseLetterOrDigit Text
s = Text -> Maybe Text
parseLetter Text
s Maybe Text -> Maybe Text -> Maybe Text
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe Text
parseDigit Text
s

parseUnderscore :: Text -> Maybe Text
parseUnderscore :: Text -> Maybe Text
parseUnderscore = (Char -> Bool) -> Text -> Maybe Text
parseSingle (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_')

parseDollar :: Text -> Maybe Text
parseDollar :: Text -> Maybe Text
parseDollar = (Char -> Bool) -> Text -> Maybe Text
parseSingle (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'$')

parseTab :: Text -> Maybe Text
parseTab :: Text -> Maybe Text
parseTab = (Char -> Bool) -> Text -> Maybe Text
parseSingle (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\t')

parseBackslash :: Text -> Maybe Text
parseBackslash :: Text -> Maybe Text
parseBackslash = (Char -> Bool) -> Text -> Maybe Text
parseSingle (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\\')

failNonEmpty :: Text -> Maybe Text
failNonEmpty :: Text -> Maybe Text
failNonEmpty Text
s | Text -> Bool
Text.null Text
s = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
Text.empty
               | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing

repeatParseN :: (Text -> Maybe Text) -> Text -> Maybe (Int, Text)
repeatParseN :: (Text -> Maybe Text) -> Text -> Maybe (Int, Text)
repeatParseN Text -> Maybe Text
parser = Int -> Text -> Maybe (Int, Text)
forall a. Num a => a -> Text -> Maybe (a, Text)
go Int
0
 where
  go :: a -> Text -> Maybe (a, Text)
go a
n Text
s0 =
    case Text -> Maybe Text
parser Text
s0 of
      Just Text
s1 -> a -> Text -> Maybe (a, Text)
go (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1) Text
s1
      Maybe Text
Nothing -> (a, Text) -> Maybe (a, Text)
forall a. a -> Maybe a
Just (a
n, Text
s0)

repeatParse :: (Text -> Maybe Text) -> Text -> Maybe Text
repeatParse :: (Text -> Maybe Text) -> Text -> Maybe Text
repeatParse Text -> Maybe Text
parser Text
s0 = (Int, Text) -> Text
forall a b. (a, b) -> b
snd ((Int, Text) -> Text) -> Maybe (Int, Text) -> Maybe Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Maybe Text) -> Text -> Maybe (Int, Text)
repeatParseN Text -> Maybe Text
parser Text
s0

-- | Encodes tuples as "TupN" and removes all characters not matching a
-- predicate.
zEncode
  :: (Char -> Bool)
  -- ^ Characters to keep
  -> Text
  -> Text
zEncode :: (Char -> Bool) -> Text -> Text
zEncode Char -> Bool
keep Text
s =
  let go :: Text -> Text
go = (Char -> Bool) -> Text -> Text
zEncode Char -> Bool
keep in
  case Text -> Maybe (Text, Text)
maybeTuple Text
s of
    Just (Text
tupName, Text
rest) ->
      Text
tupName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
go Text
rest
    Maybe (Text, Text)
Nothing ->
      case Text -> Maybe (Char, Text)
Text.uncons Text
s of
        Just (Char
c, Text
rest) ->
          if Char -> Bool
keep Char
c then
            Char -> Text -> Text
Text.cons Char
c (Text -> Text
go Text
rest)
          else
            Text -> Text
go Text
rest
        Maybe (Char, Text)
Nothing -> Text
s

prettyName :: Text -> Text
prettyName :: Text -> Text
prettyName Text
t = Text -> ((Text, Text) -> Text) -> Maybe (Text, Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
t ((Text -> Text -> Text) -> (Text, Text) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>)) (Text -> Maybe (Text, Text)
maybeTuple Text
t)

maybeTuple :: Text -> Maybe (Text, Text)
maybeTuple :: Text -> Maybe (Text, Text)
maybeTuple Text
"(# #)" = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"Unit", Text
"")
maybeTuple Text
"()" = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"Unit", Text
"")
maybeTuple Text
t = (Int -> Text) -> (Int, Text) -> (Text, Text)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\Int
n -> Text
"Tup" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
n) ((Int, Text) -> (Text, Text))
-> Maybe (Int, Text) -> Maybe (Text, Text)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (Int, Text)
parseTuple Text
t

parseTuple :: Text -> Maybe (Int, Text)
parseTuple :: Text -> Maybe (Int, Text)
parseTuple Text
t0 = do
  Text
t1 <- (Char -> Bool) -> Text -> Maybe Text
parseSingle (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'(') Text
t0
  Text
t2 <- (Char -> Bool) -> Text -> Maybe Text
parseMaybeSingle (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'#') Text
t1
  (Int
n, Text
t3) <- (Text -> Maybe Text) -> Text -> Maybe (Int, Text)
repeatParseN ((Char -> Bool) -> Text -> Maybe Text
parseSingle (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')) Text
t2
  Text
t4 <- (Char -> Bool) -> Text -> Maybe Text
parseMaybeSingle (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'#') Text
t3
  Text
t5 <- (Char -> Bool) -> Text -> Maybe Text
parseSingle (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
')') Text
t4
  (Int, Text) -> Maybe (Int, Text)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Text
t5)