{-|
  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
hdl tupEncode :: 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 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]
forall a. a -> [a] -> [a]
:['0'..'9']))
    stripLeading _    = (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]
forall a. a -> [a] -> [a]
:['0'..'9']))
    stripMultiscore :: HDL -> Text -> Text
stripMultiscore 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 (\cs :: Text
cs -> case Text -> Char
Text.head Text
cs of
                              '_' -> "_"
                              _   -> Text
cs
                    )
      ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.group
    stripMultiscore _ = 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 t :: Text
t = case Text -> Text -> Maybe Text
Text.stripPrefix "$f" Text
t of
                             Just k :: Text
k  -> (Char -> Bool) -> Text -> Text
takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '_') Text
k
                             Nothing -> Text
t

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

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

    stripSpecPrefix :: Text -> Text
stripSpecPrefix t :: Text
t = case Text -> Text -> Maybe Text
Text.stripPrefix "$s" Text
t of
                          Just k :: Text
k -> Text
k
                          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
hdl False cs :: Text
cs = Maybe (Char, Text) -> Text
go (Text -> Maybe (Char, Text)
uncons Text
cs)
  where
    go :: Maybe (Char, Text) -> Text
go Nothing         = Text
empty
    go (Just (c :: Char
c,cs' :: 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' Nothing        = Text
empty
    go' (Just (c :: Char
c,cs' :: 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
hdl True cs :: Text
cs = case Text -> Maybe (Text, Text)
maybeTuple Text
cs of
                    Just (n :: Text
n,cs' :: Text
cs') -> Text -> Text -> Text
append Text
n (Maybe (Char, Text) -> Text
go' (Text -> Maybe (Char, Text)
uncons Text
cs'))
                    Nothing      -> Maybe (Char, Text) -> Text
go (Text -> Maybe (Char, Text)
uncons Text
cs)
  where
    go :: Maybe (Char, Text) -> Text
go Nothing         = Text
empty
    go (Just (c :: Char
c,cs' :: 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' Nothing        = Text
empty
    go' (Just (c :: Char
c,cs' :: Text
cs')) = case Text -> Maybe (Text, Text)
maybeTuple (Char -> Text -> Text
cons Char
c Text
cs') of
                           Just (n :: Text
n,cs2 :: 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)
                           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 _   c :: Char
c | Char -> Bool
isDigit Char
c = Text
Text.empty -- encodeAsUnicodeChar c
encodeDigitCh hdl :: HDL
hdl c :: Char
c             = HDL -> Char -> Text
encodeCh HDL
hdl Char
c

encodeCh :: HDL -> Char -> EncodedString
encodeCh :: HDL -> Char -> Text
encodeCh hdl :: HDL
hdl c :: 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
hdl c :: 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
== '_' else Char
c Char -> [Char] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` ['_','$']
     ]

maybeTuple :: UserString -> Maybe (EncodedString,UserString)
maybeTuple :: Text -> Maybe (Text, Text)
maybeTuple "(# #)" = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just ("Unit",Text
empty)
maybeTuple "()"    = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just ("Unit",Text
empty)
maybeTuple (Text -> Maybe (Char, Text)
uncons -> Just ('(',Text -> Maybe (Char, Text)
uncons -> Just ('#',cs :: Text
cs))) =
  case Int -> Text -> (Int, Text)
countCommas 0 Text
cs of
    (n :: Int
n,Text -> Maybe (Char, Text)
uncons -> Just ('#',Text -> Maybe (Char, Text)
uncons -> Just (')',cs' :: Text
cs'))) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just ([Char] -> Text
pack ("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
+1)),Text
cs')
    _ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
maybeTuple (Text -> Maybe (Char, Text)
uncons -> Just ('(',cs :: Text
cs)) =
  case Int -> Text -> (Int, Text)
countCommas 0 Text
cs of
    (n :: Int
n,Text -> Maybe (Char, Text)
uncons -> Just (')',cs' :: Text
cs')) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just ([Char] -> Text
pack ("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
+1)),Text
cs')
    _ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
maybeTuple _  = Maybe (Text, Text)
forall a. Maybe a
Nothing

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