lcc/Hcompta/LCC/Sym/FileSystem.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'FileSystem'.
   4 module Hcompta.LCC.Sym.FileSystem where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Data.Eq (Eq)
   8 import Data.Foldable (concat)
   9 import Data.Function (($), (.))
  10 import Data.Functor (Functor(..), (<$>))
  11 import Data.Maybe (Maybe(..))
  12 import Data.Monoid (Monoid(..))
  13 import Data.Proxy
  14 import Data.Type.Equality ((:~:)(Refl))
  15 import System.IO (FilePath)
  16 import Text.Show (Show(..))
  17 import qualified Data.Text as Text
  18 import qualified Prelude ()
  19
  20 import Language.Symantic
  21 -- import Language.Symantic.Lib.Lambda
  22 import qualified Language.Symantic.Lib as Sym
  23 import Hcompta.LCC.Journal (PathFile(..))
  24
  25 -- * Class 'Sym_FileSystem'
  26 class Sym_FileSystem term where
  27         pathfile :: PathFile -> term PathFile
  28         default pathfile :: Trans t term => PathFile -> t term PathFile
  29         pathfile = trans_lift . pathfile
  30
  31 type instance Sym_of_Iface (Proxy PathFile) = Sym_FileSystem
  32 type instance TyConsts_of_Iface (Proxy PathFile) = Proxy PathFile ': TyConsts_imported_by (Proxy PathFile)
  33 type instance TyConsts_imported_by (Proxy PathFile) =
  34  [ Proxy Eq
  35  , Proxy Show
  36  ]
  37
  38 instance Sym_FileSystem HostI where
  39         pathfile = HostI
  40 instance Sym_FileSystem TextI where
  41         pathfile a = TextI $ \_p _v ->
  42                 Text.pack (show a)
  43 instance (Sym_FileSystem r1, Sym_FileSystem r2) => Sym_FileSystem (DupI r1 r2) where
  44         pathfile x = pathfile x `DupI` pathfile x
  45
  46 instance
  47  ( Read_TyNameR TyName cs rs
  48  , Inj_TyConst cs PathFile
  49  ) => Read_TyNameR TyName cs (Proxy PathFile ': rs) where
  50         read_TyNameR _cs (TyName "PathFile") k = k (ty @PathFile)
  51         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  52 instance Show_TyConst cs => Show_TyConst (Proxy PathFile ': cs) where
  53         show_TyConst TyConstZ{} = "PathFile"
  54         show_TyConst (TyConstS c) = show_TyConst c
  55
  56 instance Proj_TyFamC cs Sym.TyFam_MonoElement PathFile
  57
  58 instance -- Proj_TyConC
  59  ( Proj_TyConst cs PathFile
  60  , Proj_TyConsts cs (TyConsts_imported_by (Proxy PathFile))
  61  ) => Proj_TyConC cs (Proxy PathFile) where
  62         proj_TyConC _ (TyConst q :$ TyConst c)
  63          | Just Refl <- eq_skind (kind_of_TyConst c) SKiType
  64          , Just Refl <- proj_TyConst c (Proxy @PathFile)
  65          = case () of
  66                  _ | Just Refl <- proj_TyConst q (Proxy @Eq)   -> Just TyCon
  67                    | Just Refl <- proj_TyConst q (Proxy @Show) -> Just TyCon
  68                  _ -> Nothing
  69         proj_TyConC _c _q = Nothing
  70 data instance TokenT meta (ts::[*]) (Proxy PathFile)
  71  = Token_Term_FileSystem_PathFile PathFile
  72 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy PathFile))
  73 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy PathFile))
  74 instance -- CompileI
  75  ( Inj_TyConst cs PathFile
  76  -- , Inj_TyConst cs (->)
  77  , Proj_TyCon cs
  78  , Compile cs is
  79  ) => CompileI cs is (Proxy PathFile) where
  80         compileI tok _ctx k =
  81                 case tok of
  82                  Token_Term_FileSystem_PathFile a -> k (ty @PathFile) $ TermO $ \_c -> pathfile a
  83 instance -- TokenizeT
  84  Inj_Token meta ts PathFile =>
  85  TokenizeT meta ts (Proxy PathFile) where
  86         tokenizeT _t = mempty
  87 instance -- Gram_Term_AtomsT
  88  ( Alt g
  89  , Gram_Rule g
  90  , Gram_Lexer g
  91  , Gram_Meta meta g
  92  , Inj_Token meta ts PathFile
  93  ) => Gram_Term_AtomsT meta ts (Proxy PathFile) g where
  94         gs_term_atomsT _t =
  95          [ rule "term_pathfile" $
  96                 lexeme $ metaG $
  97                 (\a meta -> ProTok $ inj_EToken meta $ Token_Term_FileSystem_PathFile a)
  98                  <$> pathfileG
  99          ]
 100                 where
 101                 pathfileG :: CF g PathFile
 102                 pathfileG =
 103                         fmap PathFile $
 104                         (:)
 105                          <$> char '.'
 106                          <*> (concat <$> some ((:) <$> char '/' <*> pathfile_sectionG))
 107                 pathfile_sectionG :: CF g FilePath
 108                 pathfile_sectionG = some (choice $ unicat <$> [Unicat_Letter, Unicat_Number])