{-# LANGUAGE DeriveDataTypeable #-}
module Common.Id where
import Data.Char
import Data.Data
import Data.List (isPrefixOf)
import Data.Ratio
import qualified Data.Set as Set
data Pos = SourcePos
{ sourceName :: String
, sourceLine :: !Int
, sourceColumn :: !Int
} deriving (Eq, Ord, Typeable, Data)
instance Show Pos where
showsPrec _ = showPos
newtype Range = Range { rangeToList :: [Pos] }
deriving (Typeable, Data)
instance Show Range where
show _ = "nullRange"
instance Eq Range where
_ == _ = True
instance Ord Range where
compare _ _ = EQ
nullRange :: Range
nullRange = Range []
isNullRange :: Range -> Bool
isNullRange = null . rangeToList
appRange :: Range -> Range -> Range
appRange (Range l1) (Range l2) = Range $ l1 ++ l2
concatMapRange :: (a -> Range) -> [a] -> Range
concatMapRange f = Range . concatMap (rangeToList . f)
newPos :: String -> Int -> Int -> Pos
newPos = SourcePos
incSourceColumn :: Pos -> Int -> Pos
incSourceColumn (SourcePos s l c) = SourcePos s l . (c +)
showPos :: Pos -> ShowS
showPos p = let name = sourceName p
line = sourceLine p
column = sourceColumn p
in noShow (null name) (showString name . showChar ':') .
noShow (line == 0 && column == 0)
(shows line . showChar '.' . shows column)
data Token = Token { tokStr :: String
, tokPos :: Range
} deriving (Eq, Ord, Typeable, Data)
instance Show Token where
show = tokStr
instance Read Token where
readsPrec i = map (\ (a, r) -> (mkSimpleId a, r)) . readsPrec i
type SIMPLE_ID = Token
mkSimpleId :: String -> Token
mkSimpleId s = Token s nullRange
nullTok :: Token
nullTok = mkSimpleId ""
mkNumStr :: String -> Int -> String
mkNumStr str n = str ++ show n
mkNumVar :: String -> Int -> Token
mkNumVar str = mkSimpleId . mkNumStr str
isSimpleToken :: Token -> Bool
isSimpleToken t = case tokStr t of
c : r -> isAlpha c || isDigit c && null r || c == '\''
"" -> False
catPosAux :: [Token] -> [Pos]
catPosAux = concatMap (rangeToList . getRange)
catRange :: [Token] -> Range
catRange = Range . catPosAux
toRange :: Token -> [Token] -> Token -> Range
toRange o l c = catRange $ o : l ++ [c]
place :: String
place = "__"
isPlace :: Token -> Bool
isPlace (Token t _) = t == place
placeTok :: Token
placeTok = mkSimpleId place
equalS :: String
equalS = "="
exEqual :: String
exEqual = "=e="
typeTok :: Token
typeTok = mkSimpleId ":"
data Id = Id
{ getTokens :: [Token]
, getComps :: [Id]
, rangeOfId :: Range }
deriving (Eq, Ord, Typeable, Data)
instance Show Id where
showsPrec _ = showId
isNullId :: Id -> Bool
isNullId (Id ts cs r) = null ts && null cs && isNullRange r
mkId :: [Token] -> Id
mkId toks = Id toks [] nullRange
mkInfix :: String -> Id
mkInfix s = mkId [placeTok, mkSimpleId s, placeTok]
genNamePrefix :: String
genNamePrefix = "gn_"
genToken :: String -> Token
genToken = mkSimpleId . (genNamePrefix ++)
genNumVar :: String -> Int -> Token
genNumVar str = genToken . mkNumStr str
genName :: String -> Id
genName str = mkId [genToken str]
mkGenName :: Id -> Id
mkGenName i@(Id ts cs r) = case ts of
t : s -> let st = tokStr t in case st of
c : _ | isAlphaNum c -> Id (genToken st : s) cs r
| isPlace t -> Id (mkSimpleId "gn" : ts) cs r
| c == '\'' -> i
_ -> Id (mkSimpleId "gn_n" : ts) cs r
_ -> i
isGeneratedToken :: Token -> Bool
isGeneratedToken = isPrefixOf genNamePrefix . tokStr
appendString :: Id -> String -> Id
appendString (Id tokList idList range) s = let
isAlphaToken tok = case tokStr tok of
c : _ -> isAlpha c
"" -> False
genTok tList tList1 str = case tList of
[] -> [mkSimpleId $ genNamePrefix ++ "n" ++ str]
tok : tokens ->
if isPlace tok || not (isAlphaToken tok)
then genTok tokens (tok : tList1) str
else reverse tList1 ++
[tok {tokStr =
(if isGeneratedToken tok then "" else genNamePrefix)
++ tokStr tok ++ str}]
++ tokens
in Id (genTok tokList [] s) idList range
prependString :: String -> Id -> Id
prependString s (Id [] comps range) =
Id [Token s nullRange] comps range
prependString s (Id (Token t range1:toks) comps range2) =
Id (Token (s++t) range1:toks) comps range2
appendId :: Id -> Id -> Id
appendId i1 i2 =
Id (getTokens i1 ++ getTokens i2)
(getComps i1 ++ getComps i2)
(appRange (rangeOfId i1) (rangeOfId i2))
injToken :: Token
injToken = genToken "inj"
injName :: Id
injName = mkId [injToken]
mkUniqueName :: Token -> [Id] -> Id
mkUniqueName t is =
Id [foldl (\ (Token s1 r1) (Token s2 r2) ->
Token (s1 ++ "_" ++ s2) $ appRange r1 r2) t
$ concatMap getTokens is]
(let css = filter (not . null) $ map getComps is
in case css of
[] -> []
h : r -> if all (== h) r then h else concat css)
(foldl appRange nullRange $ map rangeOfId is)
projToken :: Token
projToken = genToken "proj"
projName :: Id
projName = mkId [projToken]
mkUniqueProjName :: Id -> Id -> Id
mkUniqueProjName from to = mkUniqueName projToken [from, to]
mkUniqueInjName :: Id -> Id -> Id
mkUniqueInjName from to = mkUniqueName injToken [from, to]
isInjName :: Id -> Bool
isInjName = isPrefixOf (show injName) . show
typeId :: Id
typeId = mkId [placeTok, typeTok]
applId :: Id
applId = mkId [placeTok, placeTok]
eqId :: Id
eqId = mkInfix equalS
exEq :: Id
exEq = mkInfix exEqual
noShow :: Bool -> ShowS -> ShowS
noShow b s = if b then id else s
showSepList :: ShowS -> (a -> ShowS) -> [a] -> ShowS
showSepList s f l = case l of
[] -> id
[x] -> f x
x : r -> f x . s . showSepList s f r
showIds :: [Id] -> ShowS
showIds is = noShow (null is) $ showString "["
. showSepList (showString ",") showId is
. showString "]"
showId :: Id -> ShowS
showId (Id ts is _) =
let (toks, places) = splitMixToken ts
showToks = showSepList id $ showString . tokStr
in showToks toks . showIds is . showToks places
splitMixToken :: [Token] -> ([Token], [Token])
splitMixToken ts = case ts of
[] -> ([], [])
h : l ->
let (toks, pls) = splitMixToken l
in if isPlace h && null toks
then (toks, h : pls)
else (h : toks, pls)
getListBrackets :: Id -> ([Token], [Token], [Id])
getListBrackets (Id b cs _) =
let (b1, rest) = break isPlace b
b2 = if null rest then []
else filter (not . isPlace) rest
in (b1, b2, cs)
expandPos :: (Token -> a) -> (String, String) -> [a] -> Range -> [a]
expandPos f (o, c) ts (Range ps) =
if null ts then if null ps then map (f . mkSimpleId) [o, c]
else map f (zipWith Token [o, c] [Range [head ps] , Range [last ps]])
else let
n = length ts + 1
diff = n - length ps
commas j = if j == 2 then [c] else "," : commas (j - 1)
ocs = o : commas n
hsep : tseps = map f
$ if diff == 0
then zipWith (\ s p -> Token s (Range [p])) ocs ps
else map mkSimpleId ocs
in hsep : concat (zipWith (\ t s -> [t, s]) ts tseps)
getPlainTokenList :: Id -> [Token]
getPlainTokenList = getTokenList place
getTokenList :: String -> Id -> [Token]
getTokenList placeStr (Id ts cs ps) =
let convert = map (\ t -> if isPlace t then t {tokStr = placeStr} else t)
getCompoundTokenList comps = concat .
expandPos (: []) ("[", "]") (map getPlainTokenList comps)
in if null cs then convert ts else
let (toks, pls) = splitMixToken ts in
convert toks ++ getCompoundTokenList cs ps ++ convert pls
simpleIdToId :: SIMPLE_ID -> Id
simpleIdToId sid = mkId [sid]
stringToId :: String -> Id
stringToId = simpleIdToId . mkSimpleId
isSingle :: [a] -> Bool
isSingle l = case l of
[_] -> True
_ -> False
isSimpleId :: Id -> Bool
isSimpleId (Id ts cs _) = null cs && case ts of
[t] -> isSimpleToken t
_ -> False
idToSimpleId :: Id -> Token
idToSimpleId i = case i of
Id [t] [] _ -> t
_ -> error $ "idToSimpleId: " ++ show i
placeCount :: Id -> Int
placeCount (Id tops _ _) = length $ filter isPlace tops
isMixfix :: Id -> Bool
isMixfix (Id tops _ _) = any isPlace tops
begPlace :: Id -> Bool
begPlace (Id toks _ _) = not (null toks) && isPlace (head toks)
endPlace :: Id -> Bool
endPlace (Id toks _ _) = not (null toks) && isPlace (last toks)
isPostfix :: Id -> Bool
isPostfix (Id tops _ _) = not (null tops) && isPlace (head tops)
&& not (isPlace (last tops))
isInfix :: Id -> Bool
isInfix (Id tops _ _) = not (null tops) && isPlace (head tops)
&& isPlace (last tops)
posOfId :: Id -> Range
posOfId (Id ts _ (Range ps)) =
Range $ let l = filter (not . isPlace) ts
in catPosAux (if null l then ts
else l) ++ ps
tokenRange :: Token -> [Pos]
tokenRange (Token str (Range ps)) = case ps of
[p] -> mkTokPos str p
_ -> ps
mkTokPos :: String -> Pos -> [Pos]
mkTokPos str p = let l = length str in
if l > 1 then [p, incSourceColumn p $ length str - 1] else [p]
outerRange :: Range -> [Pos]
outerRange (Range qs) = case qs of
[] -> []
q : _ -> let p = last qs in if p == q then [q] else [q, p]
sortRange :: [Pos] -> [Pos] -> [Pos]
sortRange rs qs = case qs of
[] -> rs
r : _ -> let
ps = filter ((== sourceName r) . sourceName) rs
p = minimum $ ps ++ qs
q = maximum $ ps ++ qs
in if p == q then [p] else [p, q]
joinRanges :: [[Pos]] -> [Pos]
joinRanges = foldr sortRange []
idRange :: Id -> [Pos]
idRange (Id ts _ r) =
let (fs, rs) = splitMixToken ts
in joinRanges $ map tokenRange fs ++ [outerRange r] ++ map tokenRange rs
addComponents :: Id -> ([Id], Range) -> Id
addComponents i (comps,rs) = i { getComps = getComps i ++ comps
, rangeOfId = appRange (rangeOfId i) rs}
class GetRange a where
getRange :: a -> Range
getRange = const nullRange
rangeSpan :: a -> [Pos]
rangeSpan = sortRange [] . getPosList
getPosList :: GetRange a => a -> [Pos]
getPosList = rangeToList . getRange
getRangeSpan :: GetRange a => a -> Range
getRangeSpan = Range . rangeSpan
instance GetRange Token where
getRange = Range . tokenRange
rangeSpan = tokenRange
instance GetRange Id where
getRange = posOfId
rangeSpan = idRange
instance GetRange Range where
getRange = id
rangeSpan = outerRange
instance GetRange ()
instance GetRange Char
instance GetRange Bool
instance GetRange Int
instance GetRange Integer
instance GetRange (Ratio a)
instance GetRange a => GetRange (Maybe a) where
getRange = maybe nullRange getRange
rangeSpan = maybe [] rangeSpan
instance GetRange a => GetRange [a] where
getRange = concatMapRange getRange
rangeSpan = joinRanges . map rangeSpan
instance (GetRange a, GetRange b) => GetRange (a, b) where
getRange = getRange . fst
rangeSpan (a, b) = sortRange (rangeSpan a) $ rangeSpan b
instance GetRange a => GetRange (Set.Set a) where
getRange = getRange . Set.toList
rangeSpan = rangeSpan . Set.toList