hets/Common/Data.hs

{- |
Module      :  ./Common/Data.hs
Description :  generate output from Data instances
Copyright   :  (c) Christian Maeder, DFKI GmbH 2014
License     :  GPLv2 or higher, see LICENSE.txt
Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  portable

preprocess some known data types
-}

module Common.Data where

import Common.Id
import Common.IRI
import Common.Result

import Data.Data
import Data.List

data MyData = Builtin String String -- label and content
  | ListOrTuple Bool [MyData] -- True means list
  | Cons String (Maybe [String]) [MyData] -- with optional field names
  deriving (Show, Eq, Ord)

{- | conversion with special treatment for numbers, booleans, strings,
characters, ranges, ids, IRIs and other lists. -}
dataToMyData :: Data a => a -> MyData
dataToMyData a = let
    l = gmapQ dataToMyData a
    c = toConstr a
    fs = constrFields c
    s = showConstr c
    bool = const $ Builtin "bool" s :: Bool -> MyData
    res = case l of
      [] -> case s of
        "[]" -> ListOrTuple True []
        "()" -> ListOrTuple False []
        _ -> Cons s Nothing []
      [hd, ListOrTuple True rt] | s == "(:)" -> ListOrTuple True $ hd : rt
      _ | isPrefixOf "(," s -> ListOrTuple False l
      _ -> Cons s
        (if length fs == length l && all (not . null) fs
         then Just fs else Nothing) l
  in case dataTypeRep $ dataTypeOf a of
  r | elem r [IntRep, FloatRep] -> Builtin "number" s
  CharRep -> Builtin "char" s
  _ -> maybe
       (maybe
        (maybe
         (maybe
          (maybe res
           (Builtin "iri" . iriToStringUnsecure) $ cast a)
          (Builtin "id" . (`showId` "")) $ cast a)
         (Builtin "range" . show . prettyRange . rangeToList) $ cast a)
       (Builtin "string") $ cast a) bool $ cast a

normalizeMyDataForSerialization :: MyData -> MyData
normalizeMyDataForSerialization = stripDeleted . stripSpecialConstructors
  where
    {- "_deleted" is not a valid Haskell constructor and can't clash with real
    data. It is used for marking a deleted data item. -}
    deletedData :: MyData
    deletedData = Cons "_deleted" Nothing []

    isNotDeleted :: MyData -> Bool
    isNotDeleted d = d /= deletedData

    stripSpecialConstructors :: MyData -> MyData
    stripSpecialConstructors md = case md of
      Cons "Nothing" Nothing [] -> deletedData
      Cons "Just" Nothing [value] -> value
      Cons "Left" Nothing [value] -> value
      Cons "Right" Nothing [value] -> value
      Cons constructor fieldsM values ->
        Cons constructor fieldsM $ map stripSpecialConstructors values
      ListOrTuple isList values ->
        ListOrTuple isList $ map stripSpecialConstructors values
      _ -> md

    stripDeletedList :: [MyData] -> [MyData]
    stripDeletedList values = filter isNotDeleted $ map stripDeleted values

    stripDeletedFieldsList :: [String] -> [MyData] -> ([String], [MyData])
    stripDeletedFieldsList fields values =
      unzip $
      filter (\ (_, v) -> isNotDeleted v) $
      map (\ (f, v) -> (f, stripDeleted v)) $
      zip fields values

    stripDeleted :: MyData -> MyData
    stripDeleted md = case md of
      ListOrTuple isList values ->
        ListOrTuple isList $ stripDeletedList values
      Cons constructor Nothing values ->
        Cons constructor Nothing $ stripDeletedList values
      Cons constructor (Just fields) values ->
        let (fields', values') = stripDeletedFieldsList fields values
        in Cons constructor (Just fields') values'
      _ -> md