{-|
  Copyright  :  (C) 2012-2016, University of Twente
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>

  Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Clash.Netlist.Id
  ( IdType (..)
  , mkBasicId'
  , stripDollarPrefixes
  )
where

import Clash.Annotations.Primitive (HDL (..))
import Data.Char (isAsciiLower,isAsciiUpper,isDigit)
import Data.Text as Text

data IdType = Basic | Extended

mkBasicId'
  :: HDL
  -> Bool
  -> Text
  -> Text
mkBasicId' :: HDL -> Bool -> Text -> Text
mkBasicId' HDL
hdl Bool
tupEncode = HDL -> Text -> Text
stripMultiscore HDL
hdl (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HDL -> Text -> Text
stripLeading HDL
hdl (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HDL -> Bool -> Text -> Text
zEncode HDL
hdl Bool
tupEncode
  where
    stripLeading :: HDL -> Text -> Text
stripLeading HDL
VHDL = (Char -> Bool) -> Text -> Text
Text.dropWhile (Char -> [Char] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` (Char
'_'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char
'0'..Char
'9']))
    stripLeading HDL
_    = (Char -> Bool) -> Text -> Text
Text.dropWhile (Char -> [Char] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` (Char
'$'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char
'0'..Char
'9']))
    stripMultiscore :: HDL -> Text -> Text
stripMultiscore HDL
VHDL
      = [Text] -> Text
Text.concat
      ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\Text
cs -> case Text -> Char
Text.head Text
cs of
                              Char
'_' -> Text
"_"
                              Char
_   -> Text
cs
                    )
      ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.group
    stripMultiscore HDL
_ = Text -> Text
forall a. a -> a
id

stripDollarPrefixes :: Text -> Text
stripDollarPrefixes :: Text -> Text
stripDollarPrefixes = Text -> Text
stripWorkerPrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripSpecPrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripConPrefix
                    (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripWorkerPrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
stripDictFunPrefix
  where
    stripDictFunPrefix :: Text -> Text
stripDictFunPrefix Text
t = case Text -> Text -> Maybe Text
Text.stripPrefix Text
"$f" Text
t of
                             Just Text
k  -> (Char -> Bool) -> Text -> Text
takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') Text
k
                             Maybe Text
Nothing -> Text
t

    stripWorkerPrefix :: Text -> Text
stripWorkerPrefix Text
t = case Text -> Text -> Maybe Text
Text.stripPrefix Text
"$w" Text
t of
                              Just Text
k  -> Text
k
                              Maybe Text
Nothing -> Text
t

    stripConPrefix :: Text -> Text
stripConPrefix Text
t = case Text -> Text -> Maybe Text
Text.stripPrefix Text
"$c" Text
t of
                         Just Text
k  -> Text
k
                         Maybe Text
Nothing -> Text
t

    stripSpecPrefix :: Text -> Text
stripSpecPrefix Text
t = case Text -> Text -> Maybe Text
Text.stripPrefix Text
"$s" Text
t of
                          Just Text
k -> Text
k
                          Maybe Text
Nothing -> Text
t -- snd (Text.breakOnEnd "$s" t)


type UserString    = Text -- As the user typed it
type EncodedString = Text -- Encoded form

zEncode :: HDL -> Bool -> UserString -> EncodedString
zEncode :: HDL -> Bool -> Text -> Text
zEncode HDL
hdl Bool
False Text
cs = Maybe (Char, Text) -> Text
go (Text -> Maybe (Char, Text)
uncons Text
cs)
  where
    go :: Maybe (Char, Text) -> Text
go Maybe (Char, Text)
Nothing         = Text
empty
    go (Just (Char
c,Text
cs'))  = Text -> Text -> Text
append (HDL -> Char -> Text
encodeDigitCh HDL
hdl Char
c) (Maybe (Char, Text) -> Text
go' (Maybe (Char, Text) -> Text) -> Maybe (Char, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
uncons Text
cs')
    go' :: Maybe (Char, Text) -> Text
go' Maybe (Char, Text)
Nothing        = Text
empty
    go' (Just (Char
c,Text
cs')) = Text -> Text -> Text
append (HDL -> Char -> Text
encodeCh HDL
hdl Char
c) (Maybe (Char, Text) -> Text
go' (Maybe (Char, Text) -> Text) -> Maybe (Char, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
uncons Text
cs')

zEncode HDL
hdl Bool
True Text
cs = case Text -> Maybe (Text, Text)
maybeTuple Text
cs of
                    Just (Text
n,Text
cs') -> Text -> Text -> Text
append Text
n (Maybe (Char, Text) -> Text
go' (Text -> Maybe (Char, Text)
uncons Text
cs'))
                    Maybe (Text, Text)
Nothing      -> Maybe (Char, Text) -> Text
go (Text -> Maybe (Char, Text)
uncons Text
cs)
  where
    go :: Maybe (Char, Text) -> Text
go Maybe (Char, Text)
Nothing         = Text
empty
    go (Just (Char
c,Text
cs'))  = Text -> Text -> Text
append (HDL -> Char -> Text
encodeDigitCh HDL
hdl Char
c) (Maybe (Char, Text) -> Text
go' (Maybe (Char, Text) -> Text) -> Maybe (Char, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
uncons Text
cs')
    go' :: Maybe (Char, Text) -> Text
go' Maybe (Char, Text)
Nothing        = Text
empty
    go' (Just (Char
c,Text
cs')) = case Text -> Maybe (Text, Text)
maybeTuple (Char -> Text -> Text
cons Char
c Text
cs') of
                           Just (Text
n,Text
cs2) -> Text -> Text -> Text
append Text
n (Maybe (Char, Text) -> Text
go' (Maybe (Char, Text) -> Text) -> Maybe (Char, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
uncons Text
cs2)
                           Maybe (Text, Text)
Nothing      -> Text -> Text -> Text
append (HDL -> Char -> Text
encodeCh HDL
hdl Char
c) (Maybe (Char, Text) -> Text
go' (Maybe (Char, Text) -> Text) -> Maybe (Char, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
uncons Text
cs')

encodeDigitCh :: HDL -> Char -> EncodedString
encodeDigitCh :: HDL -> Char -> Text
encodeDigitCh HDL
_   Char
c | Char -> Bool
isDigit Char
c = Text
Text.empty -- encodeAsUnicodeChar c
encodeDigitCh HDL
hdl Char
c             = HDL -> Char -> Text
encodeCh HDL
hdl Char
c

encodeCh :: HDL -> Char -> EncodedString
encodeCh :: HDL -> Char -> Text
encodeCh HDL
hdl Char
c | HDL -> Char -> Bool
unencodedChar HDL
hdl Char
c = Char -> Text
singleton Char
c     -- Common case first
               | Bool
otherwise           = Text
Text.empty

unencodedChar :: HDL -> Char -> Bool   -- True for chars that don't need encoding
unencodedChar :: HDL -> Char -> Bool
unencodedChar HDL
hdl Char
c  =
  [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
or [ Char -> Bool
isAsciiLower Char
c
     , Char -> Bool
isAsciiUpper Char
c
     , Char -> Bool
isDigit Char
c
     , if HDL
hdl HDL -> HDL -> Bool
forall a. Eq a => a -> a -> Bool
== HDL
VHDL then Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' else Char
c Char -> [Char] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Char
'_',Char
'$']
     ]

maybeTuple :: UserString -> Maybe (EncodedString,UserString)
maybeTuple :: Text -> Maybe (Text, Text)
maybeTuple Text
"(# #)" = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"Unit",Text
empty)
maybeTuple Text
"()"    = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"Unit",Text
empty)
maybeTuple (Text -> Maybe (Char, Text)
uncons -> Just (Char
'(',Text -> Maybe (Char, Text)
uncons -> Just (Char
'#',Text
cs))) =
  case Int -> Text -> (Int, Text)
countCommas Int
0 Text
cs of
    (Int
n,Text -> Maybe (Char, Text)
uncons -> Just (Char
'#',Text -> Maybe (Char, Text)
uncons -> Just (Char
')',Text
cs'))) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just ([Char] -> Text
pack ([Char]
"Tup" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)),Text
cs')
    (Int, Text)
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
maybeTuple (Text -> Maybe (Char, Text)
uncons -> Just (Char
'(',Text
cs)) =
  case Int -> Text -> (Int, Text)
countCommas Int
0 Text
cs of
    (Int
n,Text -> Maybe (Char, Text)
uncons -> Just (Char
')',Text
cs')) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just ([Char] -> Text
pack ([Char]
"Tup" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)),Text
cs')
    (Int, Text)
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
maybeTuple Text
_  = Maybe (Text, Text)
forall a. Maybe a
Nothing

countCommas :: Int -> UserString -> (Int,UserString)
countCommas :: Int -> Text -> (Int, Text)
countCommas Int
n (Text -> Maybe (Char, Text)
uncons -> Just (Char
',',Text
cs)) = Int -> Text -> (Int, Text)
countCommas (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Text
cs
countCommas Int
n Text
cs                        = (Int
n,Text
cs)